From 24265376836ec85307b84fa8b4bab39e89299245 Mon Sep 17 00:00:00 2001 From: Salvatore Date: Fri, 20 Feb 2026 13:25:08 +0100 Subject: [PATCH] added the molscat source code that were sent by flique to me (saboi) on 10/10/2025 --- POTEN_rigidXD.f90 | 10634 ++++++++++++++++++++++++ SUBROUTINES_F77.f | 1102 +++ co2_co.input | 22 + dblas.f | 7152 ++++++++++++++++ lapack.f | 12442 ++++++++++++++++++++++++++++ potenl_pes.f | 814 ++ v14_new.f | 19256 ++++++++++++++++++++++++++++++++++++++++++++ vrtp_co_co2.f | 68 + 8 files changed, 51490 insertions(+) create mode 100644 POTEN_rigidXD.f90 create mode 100644 SUBROUTINES_F77.f create mode 100644 co2_co.input create mode 100644 dblas.f create mode 100644 lapack.f create mode 100644 potenl_pes.f create mode 100644 v14_new.f create mode 100644 vrtp_co_co2.f diff --git a/POTEN_rigidXD.f90 b/POTEN_rigidXD.f90 new file mode 100644 index 0000000..ae73280 --- /dev/null +++ b/POTEN_rigidXD.f90 @@ -0,0 +1,10634 @@ +MODULE dynamic_parameters + + implicit none + save + public + real*8,allocatable :: b2(:,:),b2_lower(:,:),b2_minimal(:,:),b2_seed(:,:),d_seed(:),d(:) + real*8,allocatable :: Jac(:),Jac2(:),coords(:,:),coords_seed(:,:) + real*8,allocatable :: cart(:),dcart(:),bdist(:),ref1(:),ref2(:) + real*8,allocatable :: rmaxNS(:),rminNS(:),rmax(:),rmin(:),rmaxF(:),rminF(:),rmaxSF(:),rminSF(:) + real*8,allocatable :: pot(:),pot_seed(:),grad(:,:),grad_seed(:,:),mass(:),rminXS(:),rmaxXS(:) + integer,allocatable :: order0(:),order(:),order_min(:),order_low0(:),order_low(:) + integer,allocatable :: order_temp0(:),order_temp(:) + character(len=3),allocatable :: symb(:) + real*8 :: acc,E_limit,Max_E,Max_E_seed,E_range,ass,ass_seed,increment,E_asym,CONVE,poten,ugrad + real*8 :: epss,W_a,alpha,xbeta,dist_tol,Glob_min,XXR + integer :: focus,focus_onR,focus_onTH1,focus_onTH2,focus_onPHI,focus_onLR,smart_focus,wellfocus + integer :: basis_1,basis_2,basis_3,basis_4,ab_flag,ab_flag2 + integer :: natom,natom1,natom2,nbdist,count_seed,low_grid,subzero,dist_flag + integer :: support,count7,count3,zz,zz_low,zz4,myid,lab,permfac,maxpoints,nlinput + integer :: nfold,flip,reflect,symparts,exch,flip1,flip2 + integer :: XDIST,XDIM,XTYPE,XBAS,XSYS,XMAG +END MODULE dynamic_parameters + + +MODULE nrtype + INTEGER, PARAMETER :: I4B = SELECTED_INT_KIND(9) + INTEGER, PARAMETER :: I2B = SELECTED_INT_KIND(4) + INTEGER, PARAMETER :: I1B = SELECTED_INT_KIND(2) + INTEGER, PARAMETER :: SP = KIND(1.0D0) + INTEGER, PARAMETER :: DP = KIND(1.0D0) + INTEGER, PARAMETER :: SPC = KIND((1.0D0,1.0D0)) + INTEGER, PARAMETER :: DPC = KIND((1.0D0,1.0D0)) + INTEGER, PARAMETER :: LGT = KIND(.true.) + REAL(SP), PARAMETER :: PI=3.141592653589793238462643383279502884197_sp + REAL(SP), PARAMETER :: PIO2=1.57079632679489661923132169163975144209858_sp + REAL(SP), PARAMETER :: TWOPI=6.283185307179586476925286766559005768394_sp + REAL(SP), PARAMETER :: SQRT2=1.41421356237309504880168872420969807856967_sp + REAL(SP), PARAMETER :: EULER=0.5772156649015328606065120900824024310422_sp + REAL(DP), PARAMETER :: PI_D=3.141592653589793238462643383279502884197_dp + REAL(DP), PARAMETER :: PIO2_D=1.57079632679489661923132169163975144209858_dp + REAL(DP), PARAMETER :: TWOPI_D=6.283185307179586476925286766559005768394_dp + TYPE sprs2_sp + INTEGER(I4B) :: n,len + REAL(SP), DIMENSION(:), POINTER :: val + INTEGER(I4B), DIMENSION(:), POINTER :: irow + INTEGER(I4B), DIMENSION(:), POINTER :: jcol + END TYPE sprs2_sp + TYPE sprs2_dp + INTEGER(I4B) :: n,len + REAL(DP), DIMENSION(:), POINTER :: val + INTEGER(I4B), DIMENSION(:), POINTER :: irow + INTEGER(I4B), DIMENSION(:), POINTER :: jcol + END TYPE sprs2_dp +END MODULE nrtype + + +MODULE nr + INTERFACE + SUBROUTINE airy(x,ai,bi,aip,bip) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), INTENT(OUT) :: ai,bi,aip,bip + END SUBROUTINE airy + END INTERFACE + INTERFACE + SUBROUTINE amebsa(p,y,pb,yb,ftol,func,iter,temptr) + USE nrtype + INTEGER(I4B), INTENT(INOUT) :: iter + REAL(SP), INTENT(INOUT) :: yb + REAL(SP), INTENT(IN) :: ftol,temptr + REAL(SP), DIMENSION(:), INTENT(INOUT) :: y,pb + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: p + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP) :: func + END FUNCTION func + END INTERFACE + END SUBROUTINE amebsa + END INTERFACE + INTERFACE + SUBROUTINE amoeba(p,y,ftol,func,iter) + USE nrtype + INTEGER(I4B), INTENT(OUT) :: iter + REAL(SP), INTENT(IN) :: ftol + REAL(SP), DIMENSION(:), INTENT(INOUT) :: y + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: p + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP) :: func + END FUNCTION func + END INTERFACE + END SUBROUTINE amoeba + END INTERFACE + INTERFACE + SUBROUTINE anneal(x,y,iorder) + USE nrtype + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: iorder + REAL(SP), DIMENSION(:), INTENT(IN) :: x,y + END SUBROUTINE anneal + END INTERFACE + INTERFACE + SUBROUTINE asolve(b,x,itrnsp) + USE nrtype + REAL(DP), DIMENSION(:), INTENT(IN) :: b + REAL(DP), DIMENSION(:), INTENT(OUT) :: x + INTEGER(I4B), INTENT(IN) :: itrnsp + END SUBROUTINE asolve + END INTERFACE + INTERFACE + SUBROUTINE atimes(x,r,itrnsp) + USE nrtype + REAL(DP), DIMENSION(:), INTENT(IN) :: x + REAL(DP), DIMENSION(:), INTENT(OUT) :: r + INTEGER(I4B), INTENT(IN) :: itrnsp + END SUBROUTINE atimes + END INTERFACE + INTERFACE + SUBROUTINE avevar(data,ave,var) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: data + REAL(SP), INTENT(OUT) :: ave,var + END SUBROUTINE avevar + END INTERFACE + INTERFACE + SUBROUTINE balanc(a) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a + END SUBROUTINE balanc + END INTERFACE + INTERFACE + SUBROUTINE banbks(a,m1,m2,al,indx,b) + USE nrtype + INTEGER(I4B), INTENT(IN) :: m1,m2 + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx + REAL(SP), DIMENSION(:,:), INTENT(IN) :: a,al + REAL(SP), DIMENSION(:), INTENT(INOUT) :: b + END SUBROUTINE banbks + END INTERFACE + INTERFACE + SUBROUTINE bandec(a,m1,m2,al,indx,d) + USE nrtype + INTEGER(I4B), INTENT(IN) :: m1,m2 + INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: indx + REAL(SP), INTENT(OUT) :: d + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: al + END SUBROUTINE bandec + END INTERFACE + INTERFACE + SUBROUTINE banmul(a,m1,m2,x,b) + USE nrtype + INTEGER(I4B), INTENT(IN) :: m1,m2 + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(OUT) :: b + REAL(SP), DIMENSION(:,:), INTENT(IN) :: a + END SUBROUTINE banmul + END INTERFACE + INTERFACE + SUBROUTINE bcucof(y,y1,y2,y12,d1,d2,c) + USE nrtype + REAL(SP), INTENT(IN) :: d1,d2 + REAL(SP), DIMENSION(4), INTENT(IN) :: y,y1,y2,y12 + REAL(SP), DIMENSION(4,4), INTENT(OUT) :: c + END SUBROUTINE bcucof + END INTERFACE + INTERFACE + SUBROUTINE bcuint(y,y1,y2,y12,x1l,x1u,x2l,x2u,x1,x2,ansy,& + ansy1,ansy2) + USE nrtype + REAL(SP), DIMENSION(4), INTENT(IN) :: y,y1,y2,y12 + REAL(SP), INTENT(IN) :: x1l,x1u,x2l,x2u,x1,x2 + REAL(SP), INTENT(OUT) :: ansy,ansy1,ansy2 + END SUBROUTINE bcuint + END INTERFACE + INTERFACE beschb + SUBROUTINE beschb_s(x,gam1,gam2,gampl,gammi) + USE nrtype + REAL(DP), INTENT(IN) :: x + REAL(DP), INTENT(OUT) :: gam1,gam2,gampl,gammi + END SUBROUTINE beschb_s +!BL + SUBROUTINE beschb_v(x,gam1,gam2,gampl,gammi) + USE nrtype + REAL(DP), DIMENSION(:), INTENT(IN) :: x + REAL(DP), DIMENSION(:), INTENT(OUT) :: gam1,gam2,gampl,gammi + END SUBROUTINE beschb_v + END INTERFACE + INTERFACE bessi + FUNCTION bessi_s(n,x) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), INTENT(IN) :: x + REAL(SP) :: bessi_s + END FUNCTION bessi_s +!BL + FUNCTION bessi_v(n,x) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: bessi_v + END FUNCTION bessi_v + END INTERFACE + INTERFACE bessi0 + FUNCTION bessi0_s(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: bessi0_s + END FUNCTION bessi0_s +!BL + FUNCTION bessi0_v(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: bessi0_v + END FUNCTION bessi0_v + END INTERFACE + INTERFACE bessi1 + FUNCTION bessi1_s(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: bessi1_s + END FUNCTION bessi1_s +!BL + FUNCTION bessi1_v(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: bessi1_v + END FUNCTION bessi1_v + END INTERFACE + INTERFACE + SUBROUTINE bessik(x,xnu,ri,rk,rip,rkp) + USE nrtype + REAL(SP), INTENT(IN) :: x,xnu + REAL(SP), INTENT(OUT) :: ri,rk,rip,rkp + END SUBROUTINE bessik + END INTERFACE + INTERFACE bessj + FUNCTION bessj_s(n,x) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), INTENT(IN) :: x + REAL(SP) :: bessj_s + END FUNCTION bessj_s +!BL + FUNCTION bessj_v(n,x) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: bessj_v + END FUNCTION bessj_v + END INTERFACE + INTERFACE bessj0 + FUNCTION bessj0_s(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: bessj0_s + END FUNCTION bessj0_s +!BL + FUNCTION bessj0_v(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: bessj0_v + END FUNCTION bessj0_v + END INTERFACE + INTERFACE bessj1 + FUNCTION bessj1_s(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: bessj1_s + END FUNCTION bessj1_s +!BL + FUNCTION bessj1_v(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: bessj1_v + END FUNCTION bessj1_v + END INTERFACE + INTERFACE bessjy + SUBROUTINE bessjy_s(x,xnu,rj,ry,rjp,ryp) + USE nrtype + REAL(SP), INTENT(IN) :: x,xnu + REAL(SP), INTENT(OUT) :: rj,ry,rjp,ryp + END SUBROUTINE bessjy_s +!BL + SUBROUTINE bessjy_v(x,xnu,rj,ry,rjp,ryp) + USE nrtype + REAL(SP), INTENT(IN) :: xnu + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(OUT) :: rj,rjp,ry,ryp + END SUBROUTINE bessjy_v + END INTERFACE + INTERFACE bessk + FUNCTION bessk_s(n,x) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), INTENT(IN) :: x + REAL(SP) :: bessk_s + END FUNCTION bessk_s +!BL + FUNCTION bessk_v(n,x) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: bessk_v + END FUNCTION bessk_v + END INTERFACE + INTERFACE bessk0 + FUNCTION bessk0_s(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: bessk0_s + END FUNCTION bessk0_s +!BL + FUNCTION bessk0_v(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: bessk0_v + END FUNCTION bessk0_v + END INTERFACE + INTERFACE bessk1 + FUNCTION bessk1_s(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: bessk1_s + END FUNCTION bessk1_s +!BL + FUNCTION bessk1_v(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: bessk1_v + END FUNCTION bessk1_v + END INTERFACE + INTERFACE bessy + FUNCTION bessy_s(n,x) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), INTENT(IN) :: x + REAL(SP) :: bessy_s + END FUNCTION bessy_s +!BL + FUNCTION bessy_v(n,x) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: bessy_v + END FUNCTION bessy_v + END INTERFACE + INTERFACE bessy0 + FUNCTION bessy0_s(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: bessy0_s + END FUNCTION bessy0_s +!BL + FUNCTION bessy0_v(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: bessy0_v + END FUNCTION bessy0_v + END INTERFACE + INTERFACE bessy1 + FUNCTION bessy1_s(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: bessy1_s + END FUNCTION bessy1_s +!BL + FUNCTION bessy1_v(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: bessy1_v + END FUNCTION bessy1_v + END INTERFACE + INTERFACE beta + FUNCTION beta_s(z,w) + USE nrtype + REAL(SP), INTENT(IN) :: z,w + REAL(SP) :: beta_s + END FUNCTION beta_s +!BL + FUNCTION beta_v(z,w) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: z,w + REAL(SP), DIMENSION(size(z)) :: beta_v + END FUNCTION beta_v + END INTERFACE + INTERFACE betacf + FUNCTION betacf_s(a,b,x) + USE nrtype + REAL(SP), INTENT(IN) :: a,b,x + REAL(SP) :: betacf_s + END FUNCTION betacf_s +!BL + FUNCTION betacf_v(a,b,x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,x + REAL(SP), DIMENSION(size(x)) :: betacf_v + END FUNCTION betacf_v + END INTERFACE + INTERFACE betai + FUNCTION betai_s(a,b,x) + USE nrtype + REAL(SP), INTENT(IN) :: a,b,x + REAL(SP) :: betai_s + END FUNCTION betai_s +!BL + FUNCTION betai_v(a,b,x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,x + REAL(SP), DIMENSION(size(a)) :: betai_v + END FUNCTION betai_v + END INTERFACE + INTERFACE bico + FUNCTION bico_s(n,k) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n,k + REAL(SP) :: bico_s + END FUNCTION bico_s +!BL + FUNCTION bico_v(n,k) + USE nrtype + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n,k + REAL(SP), DIMENSION(size(n)) :: bico_v + END FUNCTION bico_v + END INTERFACE + INTERFACE + FUNCTION bnldev(pp,n) + USE nrtype + REAL(SP), INTENT(IN) :: pp + INTEGER(I4B), INTENT(IN) :: n + REAL(SP) :: bnldev + END FUNCTION bnldev + END INTERFACE + INTERFACE + FUNCTION brent(ax,bx,cx,func,tol,xmin) + USE nrtype + REAL(SP), INTENT(IN) :: ax,bx,cx,tol + REAL(SP), INTENT(OUT) :: xmin + REAL(SP) :: brent + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: func + END FUNCTION func + END INTERFACE + END FUNCTION brent + END INTERFACE + INTERFACE + SUBROUTINE broydn(x,check) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: x + LOGICAL(LGT), INTENT(OUT) :: check + END SUBROUTINE broydn + END INTERFACE + INTERFACE + SUBROUTINE bsstep(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: y + REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal + REAL(SP), INTENT(INOUT) :: x + REAL(SP), INTENT(IN) :: htry,eps + REAL(SP), INTENT(OUT) :: hdid,hnext + INTERFACE + SUBROUTINE derivs(x,y,dydx) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: y + REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx + END SUBROUTINE derivs + END INTERFACE + END SUBROUTINE bsstep + END INTERFACE + INTERFACE + SUBROUTINE caldat(julian,mm,id,iyyy) + USE nrtype + INTEGER(I4B), INTENT(IN) :: julian + INTEGER(I4B), INTENT(OUT) :: mm,id,iyyy + END SUBROUTINE caldat + END INTERFACE + INTERFACE + FUNCTION chder(a,b,c) + USE nrtype + REAL(SP), INTENT(IN) :: a,b + REAL(SP), DIMENSION(:), INTENT(IN) :: c + REAL(SP), DIMENSION(size(c)) :: chder + END FUNCTION chder + END INTERFACE + INTERFACE chebev + FUNCTION chebev_s(a,b,c,x) + USE nrtype + REAL(SP), INTENT(IN) :: a,b,x + REAL(SP), DIMENSION(:), INTENT(IN) :: c + REAL(SP) :: chebev_s + END FUNCTION chebev_s +!BL + FUNCTION chebev_v(a,b,c,x) + USE nrtype + REAL(SP), INTENT(IN) :: a,b + REAL(SP), DIMENSION(:), INTENT(IN) :: c,x + REAL(SP), DIMENSION(size(x)) :: chebev_v + END FUNCTION chebev_v + END INTERFACE + INTERFACE + FUNCTION chebft(a,b,n,func) + USE nrtype + REAL(SP), INTENT(IN) :: a,b + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), DIMENSION(n) :: chebft + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: func + END FUNCTION func + END INTERFACE + END FUNCTION chebft + END INTERFACE + INTERFACE + FUNCTION chebpc(c) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: c + REAL(SP), DIMENSION(size(c)) :: chebpc + END FUNCTION chebpc + END INTERFACE + INTERFACE + FUNCTION chint(a,b,c) + USE nrtype + REAL(SP), INTENT(IN) :: a,b + REAL(SP), DIMENSION(:), INTENT(IN) :: c + REAL(SP), DIMENSION(size(c)) :: chint + END FUNCTION chint + END INTERFACE + INTERFACE + SUBROUTINE choldc(a,p) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a + REAL(SP), DIMENSION(:), INTENT(OUT) :: p + END SUBROUTINE choldc + END INTERFACE + INTERFACE + SUBROUTINE cholsl(a,p,b,x) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(IN) :: a + REAL(SP), DIMENSION(:), INTENT(IN) :: p,b + REAL(SP), DIMENSION(:), INTENT(INOUT) :: x + END SUBROUTINE cholsl + END INTERFACE + INTERFACE + SUBROUTINE chsone(bins,ebins,knstrn,df,chsq,prob) + USE nrtype + INTEGER(I4B), INTENT(IN) :: knstrn + REAL(SP), INTENT(OUT) :: df,chsq,prob + REAL(SP), DIMENSION(:), INTENT(IN) :: bins,ebins + END SUBROUTINE chsone + END INTERFACE + INTERFACE + SUBROUTINE chstwo(bins1,bins2,knstrn,df,chsq,prob) + USE nrtype + INTEGER(I4B), INTENT(IN) :: knstrn + REAL(SP), INTENT(OUT) :: df,chsq,prob + REAL(SP), DIMENSION(:), INTENT(IN) :: bins1,bins2 + END SUBROUTINE chstwo + END INTERFACE + INTERFACE + SUBROUTINE cisi(x,ci,si) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), INTENT(OUT) :: ci,si + END SUBROUTINE cisi + END INTERFACE + INTERFACE + SUBROUTINE cntab1(nn,chisq,df,prob,cramrv,ccc) + USE nrtype + INTEGER(I4B), DIMENSION(:,:), INTENT(IN) :: nn + REAL(SP), INTENT(OUT) :: chisq,df,prob,cramrv,ccc + END SUBROUTINE cntab1 + END INTERFACE + INTERFACE + SUBROUTINE cntab2(nn,h,hx,hy,hygx,hxgy,uygx,uxgy,uxy) + USE nrtype + INTEGER(I4B), DIMENSION(:,:), INTENT(IN) :: nn + REAL(SP), INTENT(OUT) :: h,hx,hy,hygx,hxgy,uygx,uxgy,uxy + END SUBROUTINE cntab2 + END INTERFACE + INTERFACE + FUNCTION convlv(data,respns,isign) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: data + REAL(SP), DIMENSION(:), INTENT(IN) :: respns + INTEGER(I4B), INTENT(IN) :: isign + REAL(SP), DIMENSION(size(data)) :: convlv + END FUNCTION convlv + END INTERFACE + INTERFACE + FUNCTION correl(data1,data2) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 + REAL(SP), DIMENSION(size(data1)) :: correl + END FUNCTION correl + END INTERFACE + INTERFACE + SUBROUTINE cosft1(y) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: y + END SUBROUTINE cosft1 + END INTERFACE + INTERFACE + SUBROUTINE cosft2(y,isign) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: y + INTEGER(I4B), INTENT(IN) :: isign + END SUBROUTINE cosft2 + END INTERFACE + INTERFACE + SUBROUTINE covsrt(covar,maska) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: covar + LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska + END SUBROUTINE covsrt + END INTERFACE + INTERFACE + SUBROUTINE cyclic(a,b,c,alpha,beta,r,x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN):: a,b,c,r + REAL(SP), INTENT(IN) :: alpha,beta + REAL(SP), DIMENSION(:), INTENT(OUT):: x + END SUBROUTINE cyclic + END INTERFACE + INTERFACE + SUBROUTINE daub4(a,isign) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: a + INTEGER(I4B), INTENT(IN) :: isign + END SUBROUTINE daub4 + END INTERFACE + INTERFACE dawson + FUNCTION dawson_s(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: dawson_s + END FUNCTION dawson_s +!BL + FUNCTION dawson_v(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: dawson_v + END FUNCTION dawson_v + END INTERFACE + INTERFACE + FUNCTION dbrent(ax,bx,cx,func,dbrent_dfunc,tol,xmin) + USE nrtype + REAL(SP), INTENT(IN) :: ax,bx,cx,tol + REAL(SP), INTENT(OUT) :: xmin + REAL(SP) :: dbrent + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: func + END FUNCTION func +!BL + FUNCTION dbrent_dfunc(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: dbrent_dfunc + END FUNCTION dbrent_dfunc + END INTERFACE + END FUNCTION dbrent + END INTERFACE + INTERFACE + SUBROUTINE ddpoly(c,x,pd) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: c + REAL(SP), DIMENSION(:), INTENT(OUT) :: pd + END SUBROUTINE ddpoly + END INTERFACE + INTERFACE + FUNCTION decchk(string,ch) + USE nrtype + CHARACTER(1), DIMENSION(:), INTENT(IN) :: string + CHARACTER(1), INTENT(OUT) :: ch + LOGICAL(LGT) :: decchk + END FUNCTION decchk + END INTERFACE + INTERFACE + SUBROUTINE dfpmin(p,gtol,iter,fret,func,dfunc) + USE nrtype + INTEGER(I4B), INTENT(OUT) :: iter + REAL(SP), INTENT(IN) :: gtol + REAL(SP), INTENT(OUT) :: fret + REAL(SP), DIMENSION(:), INTENT(INOUT) :: p + INTERFACE + FUNCTION func(p) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: p + REAL(SP) :: func + END FUNCTION func +!BL + FUNCTION dfunc(p) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: p + REAL(SP), DIMENSION(size(p)) :: dfunc + END FUNCTION dfunc + END INTERFACE + END SUBROUTINE dfpmin + END INTERFACE + INTERFACE + FUNCTION dfridr(func,x,h,err) + USE nrtype + REAL(SP), INTENT(IN) :: x,h + REAL(SP), INTENT(OUT) :: err + REAL(SP) :: dfridr + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: func + END FUNCTION func + END INTERFACE + END FUNCTION dfridr + END INTERFACE + INTERFACE + SUBROUTINE dftcor(w,delta,a,b,endpts,corre,corim,corfac) + USE nrtype + REAL(SP), INTENT(IN) :: w,delta,a,b + REAL(SP), INTENT(OUT) :: corre,corim,corfac + REAL(SP), DIMENSION(:), INTENT(IN) :: endpts + END SUBROUTINE dftcor + END INTERFACE + INTERFACE + SUBROUTINE dftint(func,a,b,w,cosint,sinint) + USE nrtype + REAL(SP), INTENT(IN) :: a,b,w + REAL(SP), INTENT(OUT) :: cosint,sinint + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: func + END FUNCTION func + END INTERFACE + END SUBROUTINE dftint + END INTERFACE + INTERFACE + SUBROUTINE difeq(k,k1,k2,jsf,is1,isf,indexv,s,y) + USE nrtype + INTEGER(I4B), INTENT(IN) :: is1,isf,jsf,k,k1,k2 + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indexv + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: s + REAL(SP), DIMENSION(:,:), INTENT(IN) :: y + END SUBROUTINE difeq + END INTERFACE + INTERFACE + FUNCTION eclass(lista,listb,n) + USE nrtype + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: lista,listb + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B), DIMENSION(n) :: eclass + END FUNCTION eclass + END INTERFACE + INTERFACE + FUNCTION eclazz(equiv,n) + USE nrtype + INTERFACE + FUNCTION equiv(i,j) + USE nrtype + LOGICAL(LGT) :: equiv + INTEGER(I4B), INTENT(IN) :: i,j + END FUNCTION equiv + END INTERFACE + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B), DIMENSION(n) :: eclazz + END FUNCTION eclazz + END INTERFACE + INTERFACE + FUNCTION ei(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: ei + END FUNCTION ei + END INTERFACE + INTERFACE + SUBROUTINE eigsrt(d,v) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: d + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: v + END SUBROUTINE eigsrt + END INTERFACE + INTERFACE elle + FUNCTION elle_s(phi,ak) + USE nrtype + REAL(SP), INTENT(IN) :: phi,ak + REAL(SP) :: elle_s + END FUNCTION elle_s +!BL + FUNCTION elle_v(phi,ak) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: phi,ak + REAL(SP), DIMENSION(size(phi)) :: elle_v + END FUNCTION elle_v + END INTERFACE + INTERFACE ellf + FUNCTION ellf_s(phi,ak) + USE nrtype + REAL(SP), INTENT(IN) :: phi,ak + REAL(SP) :: ellf_s + END FUNCTION ellf_s +!BL + FUNCTION ellf_v(phi,ak) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: phi,ak + REAL(SP), DIMENSION(size(phi)) :: ellf_v + END FUNCTION ellf_v + END INTERFACE + INTERFACE ellpi + FUNCTION ellpi_s(phi,en,ak) + USE nrtype + REAL(SP), INTENT(IN) :: phi,en,ak + REAL(SP) :: ellpi_s + END FUNCTION ellpi_s +!BL + FUNCTION ellpi_v(phi,en,ak) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: phi,en,ak + REAL(SP), DIMENSION(size(phi)) :: ellpi_v + END FUNCTION ellpi_v + END INTERFACE + INTERFACE + SUBROUTINE elmhes(a) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a + END SUBROUTINE elmhes + END INTERFACE + INTERFACE erf + FUNCTION erf_s(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: erf_s + END FUNCTION erf_s +!BL + FUNCTION erf_v(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: erf_v + END FUNCTION erf_v + END INTERFACE + INTERFACE erfc + FUNCTION erfc_s(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: erfc_s + END FUNCTION erfc_s +!BL + FUNCTION erfc_v(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: erfc_v + END FUNCTION erfc_v + END INTERFACE + INTERFACE erfcc + FUNCTION erfcc_s(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: erfcc_s + END FUNCTION erfcc_s +!BL + FUNCTION erfcc_v(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: erfcc_v + END FUNCTION erfcc_v + END INTERFACE + INTERFACE + SUBROUTINE eulsum(sum,term,jterm) + USE nrtype + REAL(SP), INTENT(INOUT) :: sum + REAL(SP), INTENT(IN) :: term + INTEGER(I4B), INTENT(IN) :: jterm + END SUBROUTINE eulsum + END INTERFACE + INTERFACE + FUNCTION evlmem(fdt,d,xms) + USE nrtype + REAL(SP), INTENT(IN) :: fdt,xms + REAL(SP), DIMENSION(:), INTENT(IN) :: d + REAL(SP) :: evlmem + END FUNCTION evlmem + END INTERFACE + INTERFACE expdev + SUBROUTINE expdev_s(harvest) + USE nrtype + REAL(SP), INTENT(OUT) :: harvest + END SUBROUTINE expdev_s +!BL + SUBROUTINE expdev_v(harvest) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest + END SUBROUTINE expdev_v + END INTERFACE + INTERFACE + FUNCTION expint(n,x) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), INTENT(IN) :: x + REAL(SP) :: expint + END FUNCTION expint + END INTERFACE + INTERFACE factln + FUNCTION factln_s(n) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + REAL(SP) :: factln_s + END FUNCTION factln_s +!BL + FUNCTION factln_v(n) + USE nrtype + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n + REAL(SP), DIMENSION(size(n)) :: factln_v + END FUNCTION factln_v + END INTERFACE + INTERFACE factrl + FUNCTION factrl_s(n) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + REAL(SP) :: factrl_s + END FUNCTION factrl_s +!BL + FUNCTION factrl_v(n) + USE nrtype + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: n + REAL(SP), DIMENSION(size(n)) :: factrl_v + END FUNCTION factrl_v + END INTERFACE + INTERFACE + SUBROUTINE fasper(x,y,ofac,hifac,px,py,jmax,prob) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x,y + REAL(SP), INTENT(IN) :: ofac,hifac + INTEGER(I4B), INTENT(OUT) :: jmax + REAL(SP), INTENT(OUT) :: prob + REAL(SP), DIMENSION(:), POINTER :: px,py + END SUBROUTINE fasper + END INTERFACE + INTERFACE + SUBROUTINE fdjac(x,fvec,df) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: fvec + REAL(SP), DIMENSION(:), INTENT(INOUT) :: x + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: df + END SUBROUTINE fdjac + END INTERFACE + INTERFACE + SUBROUTINE fgauss(x,a,y,dyda) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x,a + REAL(SP), DIMENSION(:), INTENT(OUT) :: y + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda + END SUBROUTINE fgauss + END INTERFACE + INTERFACE + SUBROUTINE fit(x,y,a,b,siga,sigb,chi2,q,sig) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x,y + REAL(SP), INTENT(OUT) :: a,b,siga,sigb,chi2,q + REAL(SP), DIMENSION(:), OPTIONAL, INTENT(IN) :: sig + END SUBROUTINE fit + END INTERFACE + INTERFACE + SUBROUTINE fitexy(x,y,sigx,sigy,a,b,siga,sigb,chi2,q) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sigx,sigy + REAL(SP), INTENT(OUT) :: a,b,siga,sigb,chi2,q + END SUBROUTINE fitexy + END INTERFACE + INTERFACE + SUBROUTINE fixrts(d) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: d + END SUBROUTINE fixrts + END INTERFACE + INTERFACE + FUNCTION fleg(x,n) + USE nrtype + REAL(SP), INTENT(IN) :: x + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), DIMENSION(n) :: fleg + END FUNCTION fleg + END INTERFACE + INTERFACE + SUBROUTINE flmoon(n,nph,jd,frac) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n,nph + INTEGER(I4B), INTENT(OUT) :: jd + REAL(SP), INTENT(OUT) :: frac + END SUBROUTINE flmoon + END INTERFACE + INTERFACE four1 +!BL + SUBROUTINE four1_sp(data,isign) + USE nrtype + COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data + INTEGER(I4B), INTENT(IN) :: isign + END SUBROUTINE four1_sp + END INTERFACE + INTERFACE + SUBROUTINE four1_alt(data,isign) + USE nrtype + COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data + INTEGER(I4B), INTENT(IN) :: isign + END SUBROUTINE four1_alt + END INTERFACE + INTERFACE + SUBROUTINE four1_gather(data,isign) + USE nrtype + COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data + INTEGER(I4B), INTENT(IN) :: isign + END SUBROUTINE four1_gather + END INTERFACE + INTERFACE + SUBROUTINE four2(data,isign) + USE nrtype + COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data + INTEGER(I4B),INTENT(IN) :: isign + END SUBROUTINE four2 + END INTERFACE + INTERFACE + SUBROUTINE four2_alt(data,isign) + USE nrtype + COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data + INTEGER(I4B), INTENT(IN) :: isign + END SUBROUTINE four2_alt + END INTERFACE + INTERFACE + SUBROUTINE four3(data,isign) + USE nrtype + COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data + INTEGER(I4B),INTENT(IN) :: isign + END SUBROUTINE four3 + END INTERFACE + INTERFACE + SUBROUTINE four3_alt(data,isign) + USE nrtype + COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data + INTEGER(I4B), INTENT(IN) :: isign + END SUBROUTINE four3_alt + END INTERFACE + INTERFACE + SUBROUTINE fourcol(data,isign) + USE nrtype + COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data + INTEGER(I4B), INTENT(IN) :: isign + END SUBROUTINE fourcol + END INTERFACE + INTERFACE + SUBROUTINE fourcol_3d(data,isign) + USE nrtype + COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data + INTEGER(I4B), INTENT(IN) :: isign + END SUBROUTINE fourcol_3d + END INTERFACE + INTERFACE + SUBROUTINE fourn_gather(data,nn,isign) + USE nrtype + COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: data + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: nn + INTEGER(I4B), INTENT(IN) :: isign + END SUBROUTINE fourn_gather + END INTERFACE + INTERFACE +!BL + SUBROUTINE fourrow_sp(data,isign) + USE nrtype + COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: data + INTEGER(I4B), INTENT(IN) :: isign + END SUBROUTINE fourrow_sp + END INTERFACE + INTERFACE + SUBROUTINE fourrow_3d(data,isign) + USE nrtype + COMPLEX(SPC), DIMENSION(:,:,:), INTENT(INOUT) :: data + INTEGER(I4B), INTENT(IN) :: isign + END SUBROUTINE fourrow_3d + END INTERFACE + INTERFACE + FUNCTION fpoly(x,n) + USE nrtype + REAL(SP), INTENT(IN) :: x + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), DIMENSION(n) :: fpoly + END FUNCTION fpoly + END INTERFACE + INTERFACE + SUBROUTINE fred2(a,b,t,f,w,g,ak) + USE nrtype + REAL(SP), INTENT(IN) :: a,b + REAL(SP), DIMENSION(:), INTENT(OUT) :: t,f,w + INTERFACE + FUNCTION g(t) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: t + REAL(SP), DIMENSION(size(t)) :: g + END FUNCTION g +!BL + FUNCTION ak(t,s) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: t,s + REAL(SP), DIMENSION(size(t),size(s)) :: ak + END FUNCTION ak + END INTERFACE + END SUBROUTINE fred2 + END INTERFACE + INTERFACE + FUNCTION fredin(x,a,b,t,f,w,g,ak) + USE nrtype + REAL(SP), INTENT(IN) :: a,b + REAL(SP), DIMENSION(:), INTENT(IN) :: x,t,f,w + REAL(SP), DIMENSION(size(x)) :: fredin + INTERFACE + FUNCTION g(t) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: t + REAL(SP), DIMENSION(size(t)) :: g + END FUNCTION g +!BL + FUNCTION ak(t,s) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: t,s + REAL(SP), DIMENSION(size(t),size(s)) :: ak + END FUNCTION ak + END INTERFACE + END FUNCTION fredin + END INTERFACE + INTERFACE + SUBROUTINE frenel(x,s,c) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), INTENT(OUT) :: s,c + END SUBROUTINE frenel + END INTERFACE + INTERFACE + SUBROUTINE frprmn(p,ftol,iter,fret) + USE nrtype + INTEGER(I4B), INTENT(OUT) :: iter + REAL(SP), INTENT(IN) :: ftol + REAL(SP), INTENT(OUT) :: fret + REAL(SP), DIMENSION(:), INTENT(INOUT) :: p + END SUBROUTINE frprmn + END INTERFACE + INTERFACE + SUBROUTINE ftest(data1,data2,f,prob) + USE nrtype + REAL(SP), INTENT(OUT) :: f,prob + REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 + END SUBROUTINE ftest + END INTERFACE + INTERFACE + FUNCTION gamdev(ia) + USE nrtype + INTEGER(I4B), INTENT(IN) :: ia + REAL(SP) :: gamdev + END FUNCTION gamdev + END INTERFACE + INTERFACE gammln + FUNCTION gammln_s(xx) + USE nrtype + REAL(SP), INTENT(IN) :: xx + REAL(SP) :: gammln_s + END FUNCTION gammln_s +!BL + FUNCTION gammln_v(xx) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: xx + REAL(SP), DIMENSION(size(xx)) :: gammln_v + END FUNCTION gammln_v + END INTERFACE + INTERFACE gammp + FUNCTION gammp_s(a,x) + USE nrtype + REAL(SP), INTENT(IN) :: a,x + REAL(SP) :: gammp_s + END FUNCTION gammp_s +!BL + FUNCTION gammp_v(a,x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: a,x + REAL(SP), DIMENSION(size(a)) :: gammp_v + END FUNCTION gammp_v + END INTERFACE + INTERFACE gammq + FUNCTION gammq_s(a,x) + USE nrtype + REAL(SP), INTENT(IN) :: a,x + REAL(SP) :: gammq_s + END FUNCTION gammq_s +!BL + FUNCTION gammq_v(a,x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: a,x + REAL(SP), DIMENSION(size(a)) :: gammq_v + END FUNCTION gammq_v + END INTERFACE + INTERFACE gasdev + SUBROUTINE gasdev_s(harvest) + USE nrtype + REAL(SP), INTENT(OUT) :: harvest + END SUBROUTINE gasdev_s +!BL + SUBROUTINE gasdev_v(harvest) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest + END SUBROUTINE gasdev_v + END INTERFACE + INTERFACE + SUBROUTINE gaucof(a,b,amu0,x,w) + USE nrtype + REAL(SP), INTENT(IN) :: amu0 + REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b + REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w + END SUBROUTINE gaucof + END INTERFACE + INTERFACE + SUBROUTINE gauher(x,w) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w + END SUBROUTINE gauher + END INTERFACE + INTERFACE + SUBROUTINE gaujac(x,w,alf,bet) + USE nrtype + REAL(SP), INTENT(IN) :: alf,bet + REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w + END SUBROUTINE gaujac + END INTERFACE + INTERFACE + SUBROUTINE gaulag(x,w,alf) + USE nrtype + REAL(SP), INTENT(IN) :: alf + REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w + END SUBROUTINE gaulag + END INTERFACE + INTERFACE + SUBROUTINE gauleg(x1,x2,x,w) + USE nrtype + REAL(SP), INTENT(IN) :: x1,x2 + REAL(SP), DIMENSION(:), INTENT(OUT) :: x,w + END SUBROUTINE gauleg + END INTERFACE + INTERFACE + SUBROUTINE gaussj(a,b) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a,b + END SUBROUTINE gaussj + END INTERFACE + INTERFACE gcf + FUNCTION gcf_s(a,x,gln) + USE nrtype + REAL(SP), INTENT(IN) :: a,x + REAL(SP), OPTIONAL, INTENT(OUT) :: gln + REAL(SP) :: gcf_s + END FUNCTION gcf_s +!BL + FUNCTION gcf_v(a,x,gln) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: a,x + REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln + REAL(SP), DIMENSION(size(a)) :: gcf_v + END FUNCTION gcf_v + END INTERFACE + INTERFACE + FUNCTION golden(ax,bx,cx,func,tol,xmin) + USE nrtype + REAL(SP), INTENT(IN) :: ax,bx,cx,tol + REAL(SP), INTENT(OUT) :: xmin + REAL(SP) :: golden + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: func + END FUNCTION func + END INTERFACE + END FUNCTION golden + END INTERFACE + INTERFACE gser + FUNCTION gser_s(a,x,gln) + USE nrtype + REAL(SP), INTENT(IN) :: a,x + REAL(SP), OPTIONAL, INTENT(OUT) :: gln + REAL(SP) :: gser_s + END FUNCTION gser_s +!BL + FUNCTION gser_v(a,x,gln) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: a,x + REAL(SP), DIMENSION(:), OPTIONAL, INTENT(OUT) :: gln + REAL(SP), DIMENSION(size(a)) :: gser_v + END FUNCTION gser_v + END INTERFACE + INTERFACE + SUBROUTINE hqr(a,wr,wi) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(OUT) :: wr,wi + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a + END SUBROUTINE hqr + END INTERFACE + INTERFACE + SUBROUTINE hunt(xx,x,jlo) + USE nrtype + INTEGER(I4B), INTENT(INOUT) :: jlo + REAL(SP), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: xx + END SUBROUTINE hunt + END INTERFACE + INTERFACE + SUBROUTINE hypdrv(s,ry,rdyds) + USE nrtype + REAL(SP), INTENT(IN) :: s + REAL(SP), DIMENSION(:), INTENT(IN) :: ry + REAL(SP), DIMENSION(:), INTENT(OUT) :: rdyds + END SUBROUTINE hypdrv + END INTERFACE + INTERFACE + FUNCTION hypgeo(a,b,c,z) + USE nrtype + COMPLEX(SPC), INTENT(IN) :: a,b,c,z + COMPLEX(SPC) :: hypgeo + END FUNCTION hypgeo + END INTERFACE + INTERFACE + SUBROUTINE hypser(a,b,c,z,series,deriv) + USE nrtype + COMPLEX(SPC), INTENT(IN) :: a,b,c,z + COMPLEX(SPC), INTENT(OUT) :: series,deriv + END SUBROUTINE hypser + END INTERFACE + INTERFACE + FUNCTION icrc(crc,buf,jinit,jrev) + USE nrtype + CHARACTER(1), DIMENSION(:), INTENT(IN) :: buf + INTEGER(I2B), INTENT(IN) :: crc,jinit + INTEGER(I4B), INTENT(IN) :: jrev + INTEGER(I2B) :: icrc + END FUNCTION icrc + END INTERFACE + INTERFACE + FUNCTION igray(n,is) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n,is + INTEGER(I4B) :: igray + END FUNCTION igray + END INTERFACE + INTERFACE + RECURSIVE SUBROUTINE index_bypack(arr,index,partial) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: arr + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: index + INTEGER, OPTIONAL, INTENT(IN) :: partial + END SUBROUTINE index_bypack + END INTERFACE + INTERFACE indexx + SUBROUTINE indexx_sp(arr,index) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: arr + INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index + END SUBROUTINE indexx_sp + SUBROUTINE indexx_i4b(iarr,index) + USE nrtype + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: iarr + INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: index + END SUBROUTINE indexx_i4b + END INTERFACE + INTERFACE + FUNCTION interp(uc) + USE nrtype + REAL(DP), DIMENSION(:,:), INTENT(IN) :: uc + REAL(DP), DIMENSION(2*size(uc,1)-1,2*size(uc,1)-1) :: interp + END FUNCTION interp + END INTERFACE + INTERFACE + FUNCTION rank(indx) + USE nrtype + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx + INTEGER(I4B), DIMENSION(size(indx)) :: rank + END FUNCTION rank + END INTERFACE + INTERFACE + FUNCTION irbit1(iseed) + USE nrtype + INTEGER(I4B), INTENT(INOUT) :: iseed + INTEGER(I4B) :: irbit1 + END FUNCTION irbit1 + END INTERFACE + INTERFACE + FUNCTION irbit2(iseed) + USE nrtype + INTEGER(I4B), INTENT(INOUT) :: iseed + INTEGER(I4B) :: irbit2 + END FUNCTION irbit2 + END INTERFACE + INTERFACE + SUBROUTINE jacobi(a,d,v,nrot) + USE nrtype + INTEGER(I4B), INTENT(OUT) :: nrot + REAL(SP), DIMENSION(:), INTENT(OUT) :: d + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v + END SUBROUTINE jacobi + END INTERFACE + INTERFACE + SUBROUTINE jacobn(x,y,dfdx,dfdy) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: y + REAL(SP), DIMENSION(:), INTENT(OUT) :: dfdx + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dfdy + END SUBROUTINE jacobn + END INTERFACE + INTERFACE + FUNCTION julday(mm,id,iyyy) + USE nrtype + INTEGER(I4B), INTENT(IN) :: mm,id,iyyy + INTEGER(I4B) :: julday + END FUNCTION julday + END INTERFACE + INTERFACE + SUBROUTINE kendl1(data1,data2,tau,z,prob) + USE nrtype + REAL(SP), INTENT(OUT) :: tau,z,prob + REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 + END SUBROUTINE kendl1 + END INTERFACE + INTERFACE + SUBROUTINE kendl2(tab,tau,z,prob) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(IN) :: tab + REAL(SP), INTENT(OUT) :: tau,z,prob + END SUBROUTINE kendl2 + END INTERFACE + INTERFACE + FUNCTION kermom(y,m) + USE nrtype + REAL(DP), INTENT(IN) :: y + INTEGER(I4B), INTENT(IN) :: m + REAL(DP), DIMENSION(m) :: kermom + END FUNCTION kermom + END INTERFACE + INTERFACE + SUBROUTINE ks2d1s(x1,y1,quadvl,d1,prob) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x1,y1 + REAL(SP), INTENT(OUT) :: d1,prob + INTERFACE + SUBROUTINE quadvl(x,y,fa,fb,fc,fd) + USE nrtype + REAL(SP), INTENT(IN) :: x,y + REAL(SP), INTENT(OUT) :: fa,fb,fc,fd + END SUBROUTINE quadvl + END INTERFACE + END SUBROUTINE ks2d1s + END INTERFACE + INTERFACE + SUBROUTINE ks2d2s(x1,y1,x2,y2,d,prob) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x1,y1,x2,y2 + REAL(SP), INTENT(OUT) :: d,prob + END SUBROUTINE ks2d2s + END INTERFACE + INTERFACE + SUBROUTINE ksone(data,func,d,prob) + USE nrtype + REAL(SP), INTENT(OUT) :: d,prob + REAL(SP), DIMENSION(:), INTENT(INOUT) :: data + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: func + END FUNCTION func + END INTERFACE + END SUBROUTINE ksone + END INTERFACE + INTERFACE + SUBROUTINE kstwo(data1,data2,d,prob) + USE nrtype + REAL(SP), INTENT(OUT) :: d,prob + REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 + END SUBROUTINE kstwo + END INTERFACE + INTERFACE + SUBROUTINE laguer(a,x,its) + USE nrtype + INTEGER(I4B), INTENT(OUT) :: its + COMPLEX(SPC), INTENT(INOUT) :: x + COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a + END SUBROUTINE laguer + END INTERFACE + INTERFACE + SUBROUTINE lfit(x,y,sig,a,maska,covar,chisq,funcs) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig + REAL(SP), DIMENSION(:), INTENT(INOUT) :: a + LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: covar + REAL(SP), INTENT(OUT) :: chisq + INTERFACE + SUBROUTINE funcs(x,arr) + USE nrtype + REAL(SP),INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(OUT) :: arr + END SUBROUTINE funcs + END INTERFACE + END SUBROUTINE lfit + END INTERFACE + INTERFACE + SUBROUTINE linbcg(b,x,itol,tol,itmax,iter,err) + USE nrtype + REAL(DP), DIMENSION(:), INTENT(IN) :: b + REAL(DP), DIMENSION(:), INTENT(INOUT) :: x + INTEGER(I4B), INTENT(IN) :: itol,itmax + REAL(DP), INTENT(IN) :: tol + INTEGER(I4B), INTENT(OUT) :: iter + REAL(DP), INTENT(OUT) :: err + END SUBROUTINE linbcg + END INTERFACE + INTERFACE + SUBROUTINE dlinmin(p,xi,fret) + USE nrtype + REAL(SP), INTENT(OUT) :: fret + REAL(SP), DIMENSION(:), TARGET, INTENT(INOUT) :: p,xi + END SUBROUTINE dlinmin + END INTERFACE + INTERFACE + SUBROUTINE lnsrch(xold,fold,g,p,x,f,stpmax,check,func) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: xold,g + REAL(SP), DIMENSION(:), INTENT(INOUT) :: p + REAL(SP), INTENT(IN) :: fold,stpmax + REAL(SP), DIMENSION(:), INTENT(OUT) :: x + REAL(SP), INTENT(OUT) :: f + LOGICAL(LGT), INTENT(OUT) :: check + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP) :: func + REAL(SP), DIMENSION(:), INTENT(IN) :: x + END FUNCTION func + END INTERFACE + END SUBROUTINE lnsrch + END INTERFACE + INTERFACE + FUNCTION locate(xx,x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: xx + REAL(SP), INTENT(IN) :: x + INTEGER(I4B) :: locate + END FUNCTION locate + END INTERFACE + INTERFACE + FUNCTION lop(u) + USE nrtype + REAL(DP), DIMENSION(:,:), INTENT(IN) :: u + REAL(DP), DIMENSION(size(u,1),size(u,1)) :: lop + END FUNCTION lop + END INTERFACE + INTERFACE + SUBROUTINE lubksb(a,indx,b) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(IN) :: a + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx + REAL(SP), DIMENSION(:), INTENT(INOUT) :: b + END SUBROUTINE lubksb + END INTERFACE + INTERFACE + SUBROUTINE ludcmp(a,indx,d) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a + INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: indx + REAL(SP), INTENT(OUT) :: d + END SUBROUTINE ludcmp + END INTERFACE + INTERFACE + SUBROUTINE machar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,& + maxexp,eps,epsneg,xmin,xmax) + USE nrtype + INTEGER(I4B), INTENT(OUT) :: ibeta,iexp,irnd,it,machep,maxexp,& + minexp,negep,ngrd + REAL(SP), INTENT(OUT) :: eps,epsneg,xmax,xmin + END SUBROUTINE machar + END INTERFACE + INTERFACE + SUBROUTINE medfit(x,y,a,b,abdev) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x,y + REAL(SP), INTENT(OUT) :: a,b,abdev + END SUBROUTINE medfit + END INTERFACE + INTERFACE + SUBROUTINE memcof(data,xms,d) + USE nrtype + REAL(SP), INTENT(OUT) :: xms + REAL(SP), DIMENSION(:), INTENT(IN) :: data + REAL(SP), DIMENSION(:), INTENT(OUT) :: d + END SUBROUTINE memcof + END INTERFACE + INTERFACE + SUBROUTINE mgfas(u,maxcyc) + USE nrtype + REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u + INTEGER(I4B), INTENT(IN) :: maxcyc + END SUBROUTINE mgfas + END INTERFACE + INTERFACE + SUBROUTINE mglin(u,ncycle) + USE nrtype + REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u + INTEGER(I4B), INTENT(IN) :: ncycle + END SUBROUTINE mglin + END INTERFACE + INTERFACE + SUBROUTINE midexp(funk,aa,bb,s,n) + USE nrtype + REAL(SP), INTENT(IN) :: aa,bb + REAL(SP), INTENT(INOUT) :: s + INTEGER(I4B), INTENT(IN) :: n + INTERFACE + FUNCTION funk(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: funk + END FUNCTION funk + END INTERFACE + END SUBROUTINE midexp + END INTERFACE + INTERFACE + SUBROUTINE midinf(funk,aa,bb,s,n) + USE nrtype + REAL(SP), INTENT(IN) :: aa,bb + REAL(SP), INTENT(INOUT) :: s + INTEGER(I4B), INTENT(IN) :: n + INTERFACE + FUNCTION funk(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: funk + END FUNCTION funk + END INTERFACE + END SUBROUTINE midinf + END INTERFACE + INTERFACE + SUBROUTINE midpnt(func,a,b,s,n) + USE nrtype + REAL(SP), INTENT(IN) :: a,b + REAL(SP), INTENT(INOUT) :: s + INTEGER(I4B), INTENT(IN) :: n + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: func + END FUNCTION func + END INTERFACE + END SUBROUTINE midpnt + END INTERFACE + INTERFACE + SUBROUTINE midsql(funk,aa,bb,s,n) + USE nrtype + REAL(SP), INTENT(IN) :: aa,bb + REAL(SP), INTENT(INOUT) :: s + INTEGER(I4B), INTENT(IN) :: n + INTERFACE + FUNCTION funk(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: funk + END FUNCTION funk + END INTERFACE + END SUBROUTINE midsql + END INTERFACE + INTERFACE + SUBROUTINE midsqu(funk,aa,bb,s,n) + USE nrtype + REAL(SP), INTENT(IN) :: aa,bb + REAL(SP), INTENT(INOUT) :: s + INTEGER(I4B), INTENT(IN) :: n + INTERFACE + FUNCTION funk(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: funk + END FUNCTION funk + END INTERFACE + END SUBROUTINE midsqu + END INTERFACE + INTERFACE + RECURSIVE SUBROUTINE miser(func,regn,ndim,npts,dith,ave,var) + USE nrtype + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP) :: func + REAL(SP), DIMENSION(:), INTENT(IN) :: x + END FUNCTION func + END INTERFACE + REAL(SP), DIMENSION(:), INTENT(IN) :: regn + INTEGER(I4B), INTENT(IN) :: ndim,npts + REAL(SP), INTENT(IN) :: dith + REAL(SP), INTENT(OUT) :: ave,var + END SUBROUTINE miser + END INTERFACE + INTERFACE + SUBROUTINE mmid(y,dydx,xs,htot,nstep,yout,derivs) + USE nrtype + INTEGER(I4B), INTENT(IN) :: nstep + REAL(SP), INTENT(IN) :: xs,htot + REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx + REAL(SP), DIMENSION(:), INTENT(OUT) :: yout + INTERFACE + SUBROUTINE derivs(x,y,dydx) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: y + REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx + END SUBROUTINE derivs + END INTERFACE + END SUBROUTINE mmid + END INTERFACE + INTERFACE + SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,func) + USE nrtype + REAL(SP), INTENT(INOUT) :: ax,bx + REAL(SP), INTENT(OUT) :: cx,fa,fb,fc + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: func + END FUNCTION func + END INTERFACE + END SUBROUTINE mnbrak + END INTERFACE + INTERFACE + SUBROUTINE mnewt(ntrial,x,tolx,tolf,usrfun) + USE nrtype + INTEGER(I4B), INTENT(IN) :: ntrial + REAL(SP), INTENT(IN) :: tolx,tolf + REAL(SP), DIMENSION(:), INTENT(INOUT) :: x + INTERFACE + SUBROUTINE usrfun(x,fvec,fjac) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(OUT) :: fvec + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: fjac + END SUBROUTINE usrfun + END INTERFACE + END SUBROUTINE mnewt + END INTERFACE + INTERFACE + SUBROUTINE moment(data,ave,adev,sdev,var,skew,curt) + USE nrtype + REAL(SP), INTENT(OUT) :: ave,adev,sdev,var,skew,curt + REAL(SP), DIMENSION(:), INTENT(IN) :: data + END SUBROUTINE moment + END INTERFACE + INTERFACE + SUBROUTINE mp2dfr(a,s,n,m) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B), INTENT(OUT) :: m + CHARACTER(1), DIMENSION(:), INTENT(INOUT) :: a + CHARACTER(1), DIMENSION(:), INTENT(OUT) :: s + END SUBROUTINE mp2dfr + END INTERFACE + INTERFACE + SUBROUTINE mpdiv(q,r,u,v,n,m) + USE nrtype + CHARACTER(1), DIMENSION(:), INTENT(OUT) :: q,r + CHARACTER(1), DIMENSION(:), INTENT(IN) :: u,v + INTEGER(I4B), INTENT(IN) :: n,m + END SUBROUTINE mpdiv + END INTERFACE + INTERFACE + SUBROUTINE mpinv(u,v,n,m) + USE nrtype + CHARACTER(1), DIMENSION(:), INTENT(OUT) :: u + CHARACTER(1), DIMENSION(:), INTENT(IN) :: v + INTEGER(I4B), INTENT(IN) :: n,m + END SUBROUTINE mpinv + END INTERFACE + INTERFACE + SUBROUTINE mpmul(w,u,v,n,m) + USE nrtype + CHARACTER(1), DIMENSION(:), INTENT(IN) :: u,v + CHARACTER(1), DIMENSION(:), INTENT(OUT) :: w + INTEGER(I4B), INTENT(IN) :: n,m + END SUBROUTINE mpmul + END INTERFACE + INTERFACE + SUBROUTINE mppi(n) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + END SUBROUTINE mppi + END INTERFACE + INTERFACE + SUBROUTINE mprove(a,alud,indx,b,x) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(IN) :: a,alud + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indx + REAL(SP), DIMENSION(:), INTENT(IN) :: b + REAL(SP), DIMENSION(:), INTENT(INOUT) :: x + END SUBROUTINE mprove + END INTERFACE + INTERFACE + SUBROUTINE mpsqrt(w,u,v,n,m) + USE nrtype + CHARACTER(1), DIMENSION(:), INTENT(OUT) :: w,u + CHARACTER(1), DIMENSION(:), INTENT(IN) :: v + INTEGER(I4B), INTENT(IN) :: n,m + END SUBROUTINE mpsqrt + END INTERFACE + INTERFACE + SUBROUTINE mrqcof(x,y,sig,a,maska,alpha,beta,chisq,funcs) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,a,sig + REAL(SP), DIMENSION(:), INTENT(OUT) :: beta + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: alpha + REAL(SP), INTENT(OUT) :: chisq + LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska + INTERFACE + SUBROUTINE funcs(x,a,yfit,dyda) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x,a + REAL(SP), DIMENSION(:), INTENT(OUT) :: yfit + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda + END SUBROUTINE funcs + END INTERFACE + END SUBROUTINE mrqcof + END INTERFACE + INTERFACE + SUBROUTINE mrqmin(x,y,sig,a,maska,covar,alpha,chisq,funcs,alamda) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig + REAL(SP), DIMENSION(:), INTENT(INOUT) :: a + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: covar,alpha + REAL(SP), INTENT(OUT) :: chisq + REAL(SP), INTENT(INOUT) :: alamda + LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska + INTERFACE + SUBROUTINE funcs(x,a,yfit,dyda) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x,a + REAL(SP), DIMENSION(:), INTENT(OUT) :: yfit + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda + END SUBROUTINE funcs + END INTERFACE + END SUBROUTINE mrqmin + END INTERFACE + INTERFACE + SUBROUTINE newt(x,check) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: x + LOGICAL(LGT), INTENT(OUT) :: check + END SUBROUTINE newt + END INTERFACE + INTERFACE + SUBROUTINE odeint(ystart,x1,x2,eps,h1,hmin,derivs,rkqs) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: ystart + REAL(SP), INTENT(IN) :: x1,x2,eps,h1,hmin + INTERFACE + SUBROUTINE derivs(x,y,dydx) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: y + REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx + END SUBROUTINE derivs +!BL + SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: y + REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal + REAL(SP), INTENT(INOUT) :: x + REAL(SP), INTENT(IN) :: htry,eps + REAL(SP), INTENT(OUT) :: hdid,hnext + INTERFACE + SUBROUTINE derivs(x,y,dydx) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: y + REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx + END SUBROUTINE derivs + END INTERFACE + END SUBROUTINE rkqs + END INTERFACE + END SUBROUTINE odeint + END INTERFACE + INTERFACE + SUBROUTINE orthog(anu,alpha,beta,a,b) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: anu,alpha,beta + REAL(SP), DIMENSION(:), INTENT(OUT) :: a,b + END SUBROUTINE orthog + END INTERFACE + INTERFACE + SUBROUTINE pade(cof,resid) + USE nrtype + REAL(DP), DIMENSION(:), INTENT(INOUT) :: cof + REAL(SP), INTENT(OUT) :: resid + END SUBROUTINE pade + END INTERFACE + INTERFACE + FUNCTION pccheb(d) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: d + REAL(SP), DIMENSION(size(d)) :: pccheb + END FUNCTION pccheb + END INTERFACE + INTERFACE + SUBROUTINE pcshft(a,b,d) + USE nrtype + REAL(SP), INTENT(IN) :: a,b + REAL(SP), DIMENSION(:), INTENT(INOUT) :: d + END SUBROUTINE pcshft + END INTERFACE + INTERFACE + SUBROUTINE pearsn(x,y,r,prob,z) + USE nrtype + REAL(SP), INTENT(OUT) :: r,prob,z + REAL(SP), DIMENSION(:), INTENT(IN) :: x,y + END SUBROUTINE pearsn + END INTERFACE + INTERFACE + SUBROUTINE period(x,y,ofac,hifac,px,py,jmax,prob) + USE nrtype + INTEGER(I4B), INTENT(OUT) :: jmax + REAL(SP), INTENT(IN) :: ofac,hifac + REAL(SP), INTENT(OUT) :: prob + REAL(SP), DIMENSION(:), INTENT(IN) :: x,y + REAL(SP), DIMENSION(:), POINTER :: px,py + END SUBROUTINE period + END INTERFACE + INTERFACE plgndr + FUNCTION plgndr_s(l,m,x) + USE nrtype + INTEGER(I4B), INTENT(IN) :: l,m + REAL(SP), INTENT(IN) :: x + REAL(SP) :: plgndr_s + END FUNCTION plgndr_s +!BL + FUNCTION plgndr_v(l,m,x) + USE nrtype + INTEGER(I4B), INTENT(IN) :: l,m + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: plgndr_v + END FUNCTION plgndr_v + END INTERFACE + INTERFACE + FUNCTION poidev(xm) + USE nrtype + REAL(SP), INTENT(IN) :: xm + REAL(SP) :: poidev + END FUNCTION poidev + END INTERFACE + INTERFACE + FUNCTION polcoe(x,y) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x,y + REAL(SP), DIMENSION(size(x)) :: polcoe + END FUNCTION polcoe + END INTERFACE + INTERFACE + FUNCTION polcof(xa,ya) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya + REAL(SP), DIMENSION(size(xa)) :: polcof + END FUNCTION polcof + END INTERFACE + INTERFACE + SUBROUTINE poldiv(u,v,q,r) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: u,v + REAL(SP), DIMENSION(:), INTENT(OUT) :: q,r + END SUBROUTINE poldiv + END INTERFACE + INTERFACE + SUBROUTINE polin2(x1a,x2a,ya,x1,x2,y,dy) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a + REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya + REAL(SP), INTENT(IN) :: x1,x2 + REAL(SP), INTENT(OUT) :: y,dy + END SUBROUTINE polin2 + END INTERFACE + INTERFACE + SUBROUTINE polint(xa,ya,x,y,dy) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya + REAL(SP), INTENT(IN) :: x + REAL(SP), INTENT(OUT) :: y,dy + END SUBROUTINE polint + END INTERFACE + INTERFACE + SUBROUTINE powell(p,xi,ftol,iter,fret) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: p + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: xi + INTEGER(I4B), INTENT(OUT) :: iter + REAL(SP), INTENT(IN) :: ftol + REAL(SP), INTENT(OUT) :: fret + END SUBROUTINE powell + END INTERFACE + INTERFACE + FUNCTION predic(data,d,nfut) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: data,d + INTEGER(I4B), INTENT(IN) :: nfut + REAL(SP), DIMENSION(nfut) :: predic + END FUNCTION predic + END INTERFACE + INTERFACE + FUNCTION probks(alam) + USE nrtype + REAL(SP), INTENT(IN) :: alam + REAL(SP) :: probks + END FUNCTION probks + END INTERFACE + INTERFACE psdes + SUBROUTINE psdes_s(lword,rword) + USE nrtype + INTEGER(I4B), INTENT(INOUT) :: lword,rword + END SUBROUTINE psdes_s +!BL + SUBROUTINE psdes_v(lword,rword) + USE nrtype + INTEGER(I4B), DIMENSION(:), INTENT(INOUT) :: lword,rword + END SUBROUTINE psdes_v + END INTERFACE + INTERFACE + SUBROUTINE pwt(a,isign) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: a + INTEGER(I4B), INTENT(IN) :: isign + END SUBROUTINE pwt + END INTERFACE + INTERFACE + SUBROUTINE pwtset(n) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + END SUBROUTINE pwtset + END INTERFACE + INTERFACE pythag +!BL + FUNCTION pythag_sp(a,b) + USE nrtype + REAL(SP), INTENT(IN) :: a,b + REAL(SP) :: pythag_sp + END FUNCTION pythag_sp + END INTERFACE + INTERFACE + SUBROUTINE pzextr(iest,xest,yest,yz,dy) + USE nrtype + INTEGER(I4B), INTENT(IN) :: iest + REAL(SP), INTENT(IN) :: xest + REAL(SP), DIMENSION(:), INTENT(IN) :: yest + REAL(SP), DIMENSION(:), INTENT(OUT) :: yz,dy + END SUBROUTINE pzextr + END INTERFACE + INTERFACE + SUBROUTINE qrdcmp(a,c,d,sing) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a + REAL(SP), DIMENSION(:), INTENT(OUT) :: c,d + LOGICAL(LGT), INTENT(OUT) :: sing + END SUBROUTINE qrdcmp + END INTERFACE + INTERFACE + FUNCTION qromb(func,a,b) + USE nrtype + REAL(SP), INTENT(IN) :: a,b + REAL(SP) :: qromb + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: func + END FUNCTION func + END INTERFACE + END FUNCTION qromb + END INTERFACE + INTERFACE + FUNCTION qromo(func,a,b,choose) + USE nrtype + REAL(SP), INTENT(IN) :: a,b + REAL(SP) :: qromo + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: func + END FUNCTION func + END INTERFACE + INTERFACE + SUBROUTINE choose(funk,aa,bb,s,n) + USE nrtype + REAL(SP), INTENT(IN) :: aa,bb + REAL(SP), INTENT(INOUT) :: s + INTEGER(I4B), INTENT(IN) :: n + INTERFACE + FUNCTION funk(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: funk + END FUNCTION funk + END INTERFACE + END SUBROUTINE choose + END INTERFACE + END FUNCTION qromo + END INTERFACE + INTERFACE + SUBROUTINE qroot(p,b,c,eps) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: p + REAL(SP), INTENT(INOUT) :: b,c + REAL(SP), INTENT(IN) :: eps + END SUBROUTINE qroot + END INTERFACE + INTERFACE + SUBROUTINE qrsolv(a,c,d,b) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(IN) :: a + REAL(SP), DIMENSION(:), INTENT(IN) :: c,d + REAL(SP), DIMENSION(:), INTENT(INOUT) :: b + END SUBROUTINE qrsolv + END INTERFACE + INTERFACE + SUBROUTINE qrupdt(r,qt,u,v) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: r,qt + REAL(SP), DIMENSION(:), INTENT(INOUT) :: u + REAL(SP), DIMENSION(:), INTENT(IN) :: v + END SUBROUTINE qrupdt + END INTERFACE + INTERFACE + FUNCTION qsimp(func,a,b) + USE nrtype + REAL(SP), INTENT(IN) :: a,b + REAL(SP) :: qsimp + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: func + END FUNCTION func + END INTERFACE + END FUNCTION qsimp + END INTERFACE + INTERFACE + FUNCTION qtrap(func,a,b) + USE nrtype + REAL(SP), INTENT(IN) :: a,b + REAL(SP) :: qtrap + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: func + END FUNCTION func + END INTERFACE + END FUNCTION qtrap + END INTERFACE + INTERFACE + SUBROUTINE quadct(x,y,xx,yy,fa,fb,fc,fd) + USE nrtype + REAL(SP), INTENT(IN) :: x,y + REAL(SP), DIMENSION(:), INTENT(IN) :: xx,yy + REAL(SP), INTENT(OUT) :: fa,fb,fc,fd + END SUBROUTINE quadct + END INTERFACE + INTERFACE + SUBROUTINE quadmx(a) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: a + END SUBROUTINE quadmx + END INTERFACE + INTERFACE + SUBROUTINE quadvl(x,y,fa,fb,fc,fd) + USE nrtype + REAL(SP), INTENT(IN) :: x,y + REAL(SP), INTENT(OUT) :: fa,fb,fc,fd + END SUBROUTINE quadvl + END INTERFACE + INTERFACE + FUNCTION ran(idum) + INTEGER(selected_int_kind(9)), INTENT(INOUT) :: idum + REAL :: ran + END FUNCTION ran + END INTERFACE + INTERFACE ran0 + SUBROUTINE ran0_s(harvest) + USE nrtype + REAL(SP), INTENT(OUT) :: harvest + END SUBROUTINE ran0_s +!BL + SUBROUTINE ran0_v(harvest) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest + END SUBROUTINE ran0_v + END INTERFACE + INTERFACE ran1 + SUBROUTINE ran1_s(harvest) + USE nrtype + REAL(SP), INTENT(OUT) :: harvest + END SUBROUTINE ran1_s +!BL + SUBROUTINE ran1_v(harvest) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest + END SUBROUTINE ran1_v + END INTERFACE + INTERFACE ran2 + SUBROUTINE ran2_s(harvest) + USE nrtype + REAL(SP), INTENT(OUT) :: harvest + END SUBROUTINE ran2_s +!BL + SUBROUTINE ran2_v(harvest) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest + END SUBROUTINE ran2_v + END INTERFACE + INTERFACE ran3 + SUBROUTINE ran3_s(harvest) + USE nrtype + REAL(SP), INTENT(OUT) :: harvest + END SUBROUTINE ran3_s +!BL + SUBROUTINE ran3_v(harvest) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(OUT) :: harvest + END SUBROUTINE ran3_v + END INTERFACE + INTERFACE + SUBROUTINE ratint(xa,ya,x,y,dy) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya + REAL(SP), INTENT(IN) :: x + REAL(SP), INTENT(OUT) :: y,dy + END SUBROUTINE ratint + END INTERFACE + INTERFACE + SUBROUTINE ratlsq(func,a,b,mm,kk,cof,dev) + USE nrtype + REAL(DP), INTENT(IN) :: a,b + INTEGER(I4B), INTENT(IN) :: mm,kk + REAL(DP), DIMENSION(:), INTENT(OUT) :: cof + REAL(DP), INTENT(OUT) :: dev + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(DP), DIMENSION(:), INTENT(IN) :: x + REAL(DP), DIMENSION(size(x)) :: func + END FUNCTION func + END INTERFACE + END SUBROUTINE ratlsq + END INTERFACE + INTERFACE ratval + FUNCTION ratval_s(x,cof,mm,kk) + USE nrtype + REAL(DP), INTENT(IN) :: x + INTEGER(I4B), INTENT(IN) :: mm,kk + REAL(DP), DIMENSION(mm+kk+1), INTENT(IN) :: cof + REAL(DP) :: ratval_s + END FUNCTION ratval_s +!BL + FUNCTION ratval_v(x,cof,mm,kk) + USE nrtype + REAL(DP), DIMENSION(:), INTENT(IN) :: x + INTEGER(I4B), INTENT(IN) :: mm,kk + REAL(DP), DIMENSION(mm+kk+1), INTENT(IN) :: cof + REAL(DP), DIMENSION(size(x)) :: ratval_v + END FUNCTION ratval_v + END INTERFACE + INTERFACE rc + FUNCTION rc_s(x,y) + USE nrtype + REAL(SP), INTENT(IN) :: x,y + REAL(SP) :: rc_s + END FUNCTION rc_s +!BL + FUNCTION rc_v(x,y) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x,y + REAL(SP), DIMENSION(size(x)) :: rc_v + END FUNCTION rc_v + END INTERFACE + INTERFACE rd + FUNCTION rd_s(x,y,z) + USE nrtype + REAL(SP), INTENT(IN) :: x,y,z + REAL(SP) :: rd_s + END FUNCTION rd_s +!BL + FUNCTION rd_v(x,y,z) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z + REAL(SP), DIMENSION(size(x)) :: rd_v + END FUNCTION rd_v + END INTERFACE + INTERFACE realft +!BL + SUBROUTINE realft_sp(data,isign,zdata) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: data + INTEGER(I4B), INTENT(IN) :: isign + COMPLEX(SPC), DIMENSION(:), OPTIONAL, TARGET :: zdata + END SUBROUTINE realft_sp + END INTERFACE + INTERFACE + RECURSIVE FUNCTION recur1(a,b) RESULT(u) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: a,b + REAL(SP), DIMENSION(size(a)) :: u + END FUNCTION recur1 + END INTERFACE + INTERFACE + FUNCTION recur2(a,b,c) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c + REAL(SP), DIMENSION(size(a)) :: recur2 + END FUNCTION recur2 + END INTERFACE + INTERFACE + SUBROUTINE relax(u,rhs) + USE nrtype + REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u + REAL(DP), DIMENSION(:,:), INTENT(IN) :: rhs + END SUBROUTINE relax + END INTERFACE + INTERFACE + SUBROUTINE relax2(u,rhs) + USE nrtype + REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u + REAL(DP), DIMENSION(:,:), INTENT(IN) :: rhs + END SUBROUTINE relax2 + END INTERFACE + INTERFACE + FUNCTION resid(u,rhs) + USE nrtype + REAL(DP), DIMENSION(:,:), INTENT(IN) :: u,rhs + REAL(DP), DIMENSION(size(u,1),size(u,1)) :: resid + END FUNCTION resid + END INTERFACE + INTERFACE rf + FUNCTION rf_s(x,y,z) + USE nrtype + REAL(SP), INTENT(IN) :: x,y,z + REAL(SP) :: rf_s + END FUNCTION rf_s +!BL + FUNCTION rf_v(x,y,z) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z + REAL(SP), DIMENSION(size(x)) :: rf_v + END FUNCTION rf_v + END INTERFACE + INTERFACE rj + FUNCTION rj_s(x,y,z,p) + USE nrtype + REAL(SP), INTENT(IN) :: x,y,z,p + REAL(SP) :: rj_s + END FUNCTION rj_s +!BL + FUNCTION rj_v(x,y,z,p) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,z,p + REAL(SP), DIMENSION(size(x)) :: rj_v + END FUNCTION rj_v + END INTERFACE + INTERFACE + SUBROUTINE rk4(y,dydx,x,h,yout,derivs) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx + REAL(SP), INTENT(IN) :: x,h + REAL(SP), DIMENSION(:), INTENT(OUT) :: yout + INTERFACE + SUBROUTINE derivs(x,y,dydx) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: y + REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx + END SUBROUTINE derivs + END INTERFACE + END SUBROUTINE rk4 + END INTERFACE + INTERFACE + SUBROUTINE rkck(y,dydx,x,h,yout,yerr,derivs) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx + REAL(SP), INTENT(IN) :: x,h + REAL(SP), DIMENSION(:), INTENT(OUT) :: yout,yerr + INTERFACE + SUBROUTINE derivs(x,y,dydx) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: y + REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx + END SUBROUTINE derivs + END INTERFACE + END SUBROUTINE rkck + END INTERFACE + INTERFACE + SUBROUTINE rkdumb(vstart,x1,x2,nstep,derivs) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: vstart + REAL(SP), INTENT(IN) :: x1,x2 + INTEGER(I4B), INTENT(IN) :: nstep + INTERFACE + SUBROUTINE derivs(x,y,dydx) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: y + REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx + END SUBROUTINE derivs + END INTERFACE + END SUBROUTINE rkdumb + END INTERFACE + INTERFACE + SUBROUTINE rkqs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: y + REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal + REAL(SP), INTENT(INOUT) :: x + REAL(SP), INTENT(IN) :: htry,eps + REAL(SP), INTENT(OUT) :: hdid,hnext + INTERFACE + SUBROUTINE derivs(x,y,dydx) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: y + REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx + END SUBROUTINE derivs + END INTERFACE + END SUBROUTINE rkqs + END INTERFACE + INTERFACE + SUBROUTINE rlft2(data,spec,speq,isign) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: data + COMPLEX(SPC), DIMENSION(:,:), INTENT(OUT) :: spec + COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: speq + INTEGER(I4B), INTENT(IN) :: isign + END SUBROUTINE rlft2 + END INTERFACE + INTERFACE + SUBROUTINE rlft3(data,spec,speq,isign) + USE nrtype + REAL(SP), DIMENSION(:,:,:), INTENT(INOUT) :: data + COMPLEX(SPC), DIMENSION(:,:,:), INTENT(OUT) :: spec + COMPLEX(SPC), DIMENSION(:,:), INTENT(OUT) :: speq + INTEGER(I4B), INTENT(IN) :: isign + END SUBROUTINE rlft3 + END INTERFACE + INTERFACE + SUBROUTINE rotate(r,qt,i,a,b) + USE nrtype + REAL(SP), DIMENSION(:,:), TARGET, INTENT(INOUT) :: r,qt + INTEGER(I4B), INTENT(IN) :: i + REAL(SP), INTENT(IN) :: a,b + END SUBROUTINE rotate + END INTERFACE + INTERFACE + SUBROUTINE rsolv(a,d,b) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(IN) :: a + REAL(SP), DIMENSION(:), INTENT(IN) :: d + REAL(SP), DIMENSION(:), INTENT(INOUT) :: b + END SUBROUTINE rsolv + END INTERFACE + INTERFACE + FUNCTION rstrct(uf) + USE nrtype + REAL(DP), DIMENSION(:,:), INTENT(IN) :: uf + REAL(DP), DIMENSION((size(uf,1)+1)/2,(size(uf,1)+1)/2) :: rstrct + END FUNCTION rstrct + END INTERFACE + INTERFACE + FUNCTION rtbis(func,x1,x2,xacc) + USE nrtype + REAL(SP), INTENT(IN) :: x1,x2,xacc + REAL(SP) :: rtbis + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: func + END FUNCTION func + END INTERFACE + END FUNCTION rtbis + END INTERFACE + INTERFACE + FUNCTION rtflsp(func,x1,x2,xacc) + USE nrtype + REAL(SP), INTENT(IN) :: x1,x2,xacc + REAL(SP) :: rtflsp + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: func + END FUNCTION func + END INTERFACE + END FUNCTION rtflsp + END INTERFACE + INTERFACE + FUNCTION rtnewt(funcd,x1,x2,xacc) + USE nrtype + REAL(SP), INTENT(IN) :: x1,x2,xacc + REAL(SP) :: rtnewt + INTERFACE + SUBROUTINE funcd(x,fval,fderiv) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), INTENT(OUT) :: fval,fderiv + END SUBROUTINE funcd + END INTERFACE + END FUNCTION rtnewt + END INTERFACE + INTERFACE + FUNCTION rtsafe(funcd,x1,x2,xacc) + USE nrtype + REAL(SP), INTENT(IN) :: x1,x2,xacc + REAL(SP) :: rtsafe + INTERFACE + SUBROUTINE funcd(x,fval,fderiv) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), INTENT(OUT) :: fval,fderiv + END SUBROUTINE funcd + END INTERFACE + END FUNCTION rtsafe + END INTERFACE + INTERFACE + FUNCTION rtsec(func,x1,x2,xacc) + USE nrtype + REAL(SP), INTENT(IN) :: x1,x2,xacc + REAL(SP) :: rtsec + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: func + END FUNCTION func + END INTERFACE + END FUNCTION rtsec + END INTERFACE + INTERFACE + SUBROUTINE rzextr(iest,xest,yest,yz,dy) + USE nrtype + INTEGER(I4B), INTENT(IN) :: iest + REAL(SP), INTENT(IN) :: xest + REAL(SP), DIMENSION(:), INTENT(IN) :: yest + REAL(SP), DIMENSION(:), INTENT(OUT) :: yz,dy + END SUBROUTINE rzextr + END INTERFACE + INTERFACE + FUNCTION savgol(nl,nrr,ld,m) + USE nrtype + INTEGER(I4B), INTENT(IN) :: nl,nrr,ld,m + REAL(SP), DIMENSION(nl+nrr+1) :: savgol + END FUNCTION savgol + END INTERFACE + INTERFACE + SUBROUTINE scrsho(func) + USE nrtype + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: func + END FUNCTION func + END INTERFACE + END SUBROUTINE scrsho + END INTERFACE + INTERFACE + FUNCTION select(k,arr) + USE nrtype + INTEGER(I4B), INTENT(IN) :: k + REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr + REAL(SP) :: select + END FUNCTION select + END INTERFACE + INTERFACE + FUNCTION select_bypack(k,arr) + USE nrtype + INTEGER(I4B), INTENT(IN) :: k + REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr + REAL(SP) :: select_bypack + END FUNCTION select_bypack + END INTERFACE + INTERFACE + SUBROUTINE select_heap(arr,heap) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: arr + REAL(SP), DIMENSION(:), INTENT(OUT) :: heap + END SUBROUTINE select_heap + END INTERFACE + INTERFACE + FUNCTION select_inplace(k,arr) + USE nrtype + INTEGER(I4B), INTENT(IN) :: k + REAL(SP), DIMENSION(:), INTENT(IN) :: arr + REAL(SP) :: select_inplace + END FUNCTION select_inplace + END INTERFACE + INTERFACE + SUBROUTINE simplx(a,m1,m2,m3,icase,izrov,iposv) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a + INTEGER(I4B), INTENT(IN) :: m1,m2,m3 + INTEGER(I4B), INTENT(OUT) :: icase + INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: izrov,iposv + END SUBROUTINE simplx + END INTERFACE + INTERFACE + SUBROUTINE simpr(y,dydx,dfdx,dfdy,xs,htot,nstep,yout,derivs) + USE nrtype + REAL(SP), INTENT(IN) :: xs,htot + REAL(SP), DIMENSION(:), INTENT(IN) :: y,dydx,dfdx + REAL(SP), DIMENSION(:,:), INTENT(IN) :: dfdy + INTEGER(I4B), INTENT(IN) :: nstep + REAL(SP), DIMENSION(:), INTENT(OUT) :: yout + INTERFACE + SUBROUTINE derivs(x,y,dydx) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: y + REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx + END SUBROUTINE derivs + END INTERFACE + END SUBROUTINE simpr + END INTERFACE + INTERFACE + SUBROUTINE sinft(y) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: y + END SUBROUTINE sinft + END INTERFACE + INTERFACE + SUBROUTINE slvsm2(u,rhs) + USE nrtype + REAL(DP), DIMENSION(3,3), INTENT(OUT) :: u + REAL(DP), DIMENSION(3,3), INTENT(IN) :: rhs + END SUBROUTINE slvsm2 + END INTERFACE + INTERFACE + SUBROUTINE slvsml(u,rhs) + USE nrtype + REAL(DP), DIMENSION(3,3), INTENT(OUT) :: u + REAL(DP), DIMENSION(3,3), INTENT(IN) :: rhs + END SUBROUTINE slvsml + END INTERFACE + INTERFACE + SUBROUTINE sncndn(uu,emmc,sn,cn,dn) + USE nrtype + REAL(SP), INTENT(IN) :: uu,emmc + REAL(SP), INTENT(OUT) :: sn,cn,dn + END SUBROUTINE sncndn + END INTERFACE + INTERFACE + FUNCTION snrm(sx,itol) + USE nrtype + REAL(DP), DIMENSION(:), INTENT(IN) :: sx + INTEGER(I4B), INTENT(IN) :: itol + REAL(DP) :: snrm + END FUNCTION snrm + END INTERFACE + INTERFACE + SUBROUTINE sobseq(x,init) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(OUT) :: x + INTEGER(I4B), OPTIONAL, INTENT(IN) :: init + END SUBROUTINE sobseq + END INTERFACE + INTERFACE + SUBROUTINE solvde(itmax,conv,slowc,scalv,indexv,nb,y) + USE nrtype + INTEGER(I4B), INTENT(IN) :: itmax,nb + REAL(SP), INTENT(IN) :: conv,slowc + REAL(SP), DIMENSION(:), INTENT(IN) :: scalv + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: indexv + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: y + END SUBROUTINE solvde + END INTERFACE + INTERFACE + SUBROUTINE sor(a,b,c,d,e,f,u,rjac) + USE nrtype + REAL(DP), DIMENSION(:,:), INTENT(IN) :: a,b,c,d,e,f + REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: u + REAL(DP), INTENT(IN) :: rjac + END SUBROUTINE sor + END INTERFACE + INTERFACE + SUBROUTINE sort(arr) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr + END SUBROUTINE sort + END INTERFACE + INTERFACE + SUBROUTINE sort2(arr,slave) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr,slave + END SUBROUTINE sort2 + END INTERFACE + INTERFACE + SUBROUTINE sort3(arr,slave1,slave2) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr,slave1,slave2 + END SUBROUTINE sort3 + END INTERFACE + INTERFACE + SUBROUTINE sort_bypack(arr) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr + END SUBROUTINE sort_bypack + END INTERFACE + INTERFACE + SUBROUTINE sort_byreshape(arr) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr + END SUBROUTINE sort_byreshape + END INTERFACE + INTERFACE + SUBROUTINE sort_heap(arr) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr + END SUBROUTINE sort_heap + END INTERFACE + INTERFACE + SUBROUTINE sort_pick(arr) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr + END SUBROUTINE sort_pick + END INTERFACE + INTERFACE + SUBROUTINE sort_radix(arr) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr + END SUBROUTINE sort_radix + END INTERFACE + INTERFACE + SUBROUTINE sort_shell(arr) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: arr + END SUBROUTINE sort_shell + END INTERFACE + INTERFACE + SUBROUTINE spctrm(p,k,ovrlap,unit,n_window) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(OUT) :: p + INTEGER(I4B), INTENT(IN) :: k + LOGICAL(LGT), INTENT(IN) :: ovrlap + INTEGER(I4B), OPTIONAL, INTENT(IN) :: n_window,unit + END SUBROUTINE spctrm + END INTERFACE + INTERFACE + SUBROUTINE spear(data1,data2,d,zd,probd,rs,probrs) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 + REAL(SP), INTENT(OUT) :: d,zd,probd,rs,probrs + END SUBROUTINE spear + END INTERFACE + INTERFACE sphbes + SUBROUTINE sphbes_s(n,x,sj,sy,sjp,syp) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), INTENT(IN) :: x + REAL(SP), INTENT(OUT) :: sj,sy,sjp,syp + END SUBROUTINE sphbes_s +!BL + SUBROUTINE sphbes_v(n,x,sj,sy,sjp,syp) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(OUT) :: sj,sy,sjp,syp + END SUBROUTINE sphbes_v + END INTERFACE + INTERFACE + SUBROUTINE splie2(x1a,x2a,ya,y2a) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a + REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: y2a + END SUBROUTINE splie2 + END INTERFACE + INTERFACE + FUNCTION splin2(x1a,x2a,ya,y2a,x1,x2) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x1a,x2a + REAL(SP), DIMENSION(:,:), INTENT(IN) :: ya,y2a + REAL(SP), INTENT(IN) :: x1,x2 + REAL(SP) :: splin2 + END FUNCTION splin2 + END INTERFACE + INTERFACE + SUBROUTINE spline(x,y,yp1,ypn,y2) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x,y + REAL(SP), INTENT(IN) :: yp1,ypn + REAL(SP), DIMENSION(:), INTENT(OUT) :: y2 + END SUBROUTINE spline + END INTERFACE + INTERFACE + FUNCTION splint(xa,ya,y2a,x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: xa,ya,y2a + REAL(SP), INTENT(IN) :: x + REAL(SP) :: splint + END FUNCTION splint + END INTERFACE + INTERFACE sprsax + SUBROUTINE sprsax_dp(sa,x,b) + USE nrtype + TYPE(sprs2_dp), INTENT(IN) :: sa + REAL(DP), DIMENSION (:), INTENT(IN) :: x + REAL(DP), DIMENSION (:), INTENT(OUT) :: b + END SUBROUTINE sprsax_dp +!BL + SUBROUTINE sprsax_sp(sa,x,b) + USE nrtype + TYPE(sprs2_sp), INTENT(IN) :: sa + REAL(SP), DIMENSION (:), INTENT(IN) :: x + REAL(SP), DIMENSION (:), INTENT(OUT) :: b + END SUBROUTINE sprsax_sp + END INTERFACE + INTERFACE sprsdiag + SUBROUTINE sprsdiag_dp(sa,b) + USE nrtype + TYPE(sprs2_dp), INTENT(IN) :: sa + REAL(DP), DIMENSION(:), INTENT(OUT) :: b + END SUBROUTINE sprsdiag_dp +!BL + SUBROUTINE sprsdiag_sp(sa,b) + USE nrtype + TYPE(sprs2_sp), INTENT(IN) :: sa + REAL(SP), DIMENSION(:), INTENT(OUT) :: b + END SUBROUTINE sprsdiag_sp + END INTERFACE + INTERFACE sprsin + SUBROUTINE sprsin_sp(a,thresh,sa) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(IN) :: a + REAL(SP), INTENT(IN) :: thresh + TYPE(sprs2_sp), INTENT(OUT) :: sa + END SUBROUTINE sprsin_sp +!BL + SUBROUTINE sprsin_dp(a,thresh,sa) + USE nrtype + REAL(DP), DIMENSION(:,:), INTENT(IN) :: a + REAL(DP), INTENT(IN) :: thresh + TYPE(sprs2_dp), INTENT(OUT) :: sa + END SUBROUTINE sprsin_dp + END INTERFACE + INTERFACE + SUBROUTINE sprstp(sa) + USE nrtype + TYPE(sprs2_sp), INTENT(INOUT) :: sa + END SUBROUTINE sprstp + END INTERFACE + INTERFACE sprstx + SUBROUTINE sprstx_dp(sa,x,b) + USE nrtype + TYPE(sprs2_dp), INTENT(IN) :: sa + REAL(DP), DIMENSION (:), INTENT(IN) :: x + REAL(DP), DIMENSION (:), INTENT(OUT) :: b + END SUBROUTINE sprstx_dp +!BL + SUBROUTINE sprstx_sp(sa,x,b) + USE nrtype + TYPE(sprs2_sp), INTENT(IN) :: sa + REAL(SP), DIMENSION (:), INTENT(IN) :: x + REAL(SP), DIMENSION (:), INTENT(OUT) :: b + END SUBROUTINE sprstx_sp + END INTERFACE + INTERFACE + SUBROUTINE stifbs(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: y + REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal + REAL(SP), INTENT(IN) :: htry,eps + REAL(SP), INTENT(INOUT) :: x + REAL(SP), INTENT(OUT) :: hdid,hnext + INTERFACE + SUBROUTINE derivs(x,y,dydx) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: y + REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx + END SUBROUTINE derivs + END INTERFACE + END SUBROUTINE stifbs + END INTERFACE + INTERFACE + SUBROUTINE stiff(y,dydx,x,htry,eps,yscal,hdid,hnext,derivs) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: y + REAL(SP), DIMENSION(:), INTENT(IN) :: dydx,yscal + REAL(SP), INTENT(INOUT) :: x + REAL(SP), INTENT(IN) :: htry,eps + REAL(SP), INTENT(OUT) :: hdid,hnext + INTERFACE + SUBROUTINE derivs(x,y,dydx) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: y + REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx + END SUBROUTINE derivs + END INTERFACE + END SUBROUTINE stiff + END INTERFACE + INTERFACE + SUBROUTINE stoerm(y,d2y,xs,htot,nstep,yout,derivs) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: y,d2y + REAL(SP), INTENT(IN) :: xs,htot + INTEGER(I4B), INTENT(IN) :: nstep + REAL(SP), DIMENSION(:), INTENT(OUT) :: yout + INTERFACE + SUBROUTINE derivs(x,y,dydx) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: y + REAL(SP), DIMENSION(:), INTENT(OUT) :: dydx + END SUBROUTINE derivs + END INTERFACE + END SUBROUTINE stoerm + END INTERFACE + INTERFACE svbksb +!BL + SUBROUTINE svbksb_sp(u,w,v,b,x) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(IN) :: u,v + REAL(SP), DIMENSION(:), INTENT(IN) :: w,b + REAL(SP), DIMENSION(:), INTENT(OUT) :: x + END SUBROUTINE svbksb_sp + END INTERFACE + INTERFACE svdcmp +!BL + SUBROUTINE svdcmp_sp(a,w,v) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a + REAL(SP), DIMENSION(:), INTENT(OUT) :: w + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v + END SUBROUTINE svdcmp_sp + END INTERFACE + INTERFACE + SUBROUTINE svdfit(x,y,sig,a,v,w,chisq,funcs) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig + REAL(SP), DIMENSION(:), INTENT(OUT) :: a,w + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: v + REAL(SP), INTENT(OUT) :: chisq + INTERFACE + FUNCTION funcs(x,n) + USE nrtype + REAL(SP), INTENT(IN) :: x + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), DIMENSION(n) :: funcs + END FUNCTION funcs + END INTERFACE + END SUBROUTINE svdfit + END INTERFACE + INTERFACE + SUBROUTINE svdvar(v,w,cvm) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(IN) :: v + REAL(SP), DIMENSION(:), INTENT(IN) :: w + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: cvm + END SUBROUTINE svdvar + END INTERFACE + INTERFACE + FUNCTION toeplz(r,y) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: r,y + REAL(SP), DIMENSION(size(y)) :: toeplz + END FUNCTION toeplz + END INTERFACE + INTERFACE + SUBROUTINE tptest(data1,data2,t,prob) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 + REAL(SP), INTENT(OUT) :: t,prob + END SUBROUTINE tptest + END INTERFACE + INTERFACE + SUBROUTINE tqli(d,e,z) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: d,e + REAL(SP), DIMENSION(:,:), OPTIONAL, INTENT(INOUT) :: z + END SUBROUTINE tqli + END INTERFACE + INTERFACE + SUBROUTINE trapzd(func,a,b,s,n) + USE nrtype + REAL(SP), INTENT(IN) :: a,b + REAL(SP), INTENT(INOUT) :: s + INTEGER(I4B), INTENT(IN) :: n + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: x + REAL(SP), DIMENSION(size(x)) :: func + END FUNCTION func + END INTERFACE + END SUBROUTINE trapzd + END INTERFACE + INTERFACE + SUBROUTINE tred2(a,d,e,novectors) + USE nrtype + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a + REAL(SP), DIMENSION(:), INTENT(OUT) :: d,e + LOGICAL(LGT), OPTIONAL, INTENT(IN) :: novectors + END SUBROUTINE tred2 + END INTERFACE +! On a purely serial machine, for greater efficiency, remove +! the generic name tridag from the following interface, +! and put it on the next one after that. + INTERFACE tridag + RECURSIVE SUBROUTINE tridag_par(a,b,c,r,u) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r + REAL(SP), DIMENSION(:), INTENT(OUT) :: u + END SUBROUTINE tridag_par + END INTERFACE + INTERFACE + SUBROUTINE tridag_ser(a,b,c,r,u) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: a,b,c,r + REAL(SP), DIMENSION(:), INTENT(OUT) :: u + END SUBROUTINE tridag_ser + END INTERFACE + INTERFACE + SUBROUTINE ttest(data1,data2,t,prob) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 + REAL(SP), INTENT(OUT) :: t,prob + END SUBROUTINE ttest + END INTERFACE + INTERFACE + SUBROUTINE tutest(data1,data2,t,prob) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 + REAL(SP), INTENT(OUT) :: t,prob + END SUBROUTINE tutest + END INTERFACE + INTERFACE + SUBROUTINE twofft(data1,data2,fft1,fft2) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: data1,data2 + COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: fft1,fft2 + END SUBROUTINE twofft + END INTERFACE + INTERFACE + FUNCTION vander(x,q) + USE nrtype + REAL(DP), DIMENSION(:), INTENT(IN) :: x,q + REAL(DP), DIMENSION(size(x)) :: vander + END FUNCTION vander + END INTERFACE + INTERFACE + SUBROUTINE vegas(region,func,init,ncall,itmx,nprn,tgral,sd,chi2a) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: region + INTEGER(I4B), INTENT(IN) :: init,ncall,itmx,nprn + REAL(SP), INTENT(OUT) :: tgral,sd,chi2a + INTERFACE + FUNCTION func(pt,wgt) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: pt + REAL(SP), INTENT(IN) :: wgt + REAL(SP) :: func + END FUNCTION func + END INTERFACE + END SUBROUTINE vegas + END INTERFACE + INTERFACE + SUBROUTINE voltra(t0,h,t,f,g,ak) + USE nrtype + REAL(SP), INTENT(IN) :: t0,h + REAL(SP), DIMENSION(:), INTENT(OUT) :: t + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: f + INTERFACE + FUNCTION g(t) + USE nrtype + REAL(SP), INTENT(IN) :: t + REAL(SP), DIMENSION(:), POINTER :: g + END FUNCTION g +!BL + FUNCTION ak(t,s) + USE nrtype + REAL(SP), INTENT(IN) :: t,s + REAL(SP), DIMENSION(:,:), POINTER :: ak + END FUNCTION ak + END INTERFACE + END SUBROUTINE voltra + END INTERFACE + INTERFACE + SUBROUTINE wt1(a,isign,wtstep) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: a + INTEGER(I4B), INTENT(IN) :: isign + INTERFACE + SUBROUTINE wtstep(a,isign) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: a + INTEGER(I4B), INTENT(IN) :: isign + END SUBROUTINE wtstep + END INTERFACE + END SUBROUTINE wt1 + END INTERFACE + INTERFACE + SUBROUTINE wtn(a,nn,isign,wtstep) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: a + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: nn + INTEGER(I4B), INTENT(IN) :: isign + INTERFACE + SUBROUTINE wtstep(a,isign) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(INOUT) :: a + INTEGER(I4B), INTENT(IN) :: isign + END SUBROUTINE wtstep + END INTERFACE + END SUBROUTINE wtn + END INTERFACE + INTERFACE + FUNCTION wwghts(n,h,kermom) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), INTENT(IN) :: h + REAL(SP), DIMENSION(n) :: wwghts + INTERFACE + FUNCTION kermom(y,m) + USE nrtype + REAL(DP), INTENT(IN) :: y + INTEGER(I4B), INTENT(IN) :: m + REAL(DP), DIMENSION(m) :: kermom + END FUNCTION kermom + END INTERFACE + END FUNCTION wwghts + END INTERFACE + INTERFACE + SUBROUTINE zbrac(func,x1,x2,succes) + USE nrtype + REAL(SP), INTENT(INOUT) :: x1,x2 + LOGICAL(LGT), INTENT(OUT) :: succes + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: func + END FUNCTION func + END INTERFACE + END SUBROUTINE zbrac + END INTERFACE + INTERFACE + SUBROUTINE zbrak(func,x1,x2,n,xb1,xb2,nb) + USE nrtype + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B), INTENT(OUT) :: nb + REAL(SP), INTENT(IN) :: x1,x2 + REAL(SP), DIMENSION(:), POINTER :: xb1,xb2 + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: func + END FUNCTION func + END INTERFACE + END SUBROUTINE zbrak + END INTERFACE + INTERFACE + FUNCTION zbrent(func,x1,x2,tol) + USE nrtype + REAL(SP), INTENT(IN) :: x1,x2,tol + REAL(SP) :: zbrent + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: func + END FUNCTION func + END INTERFACE + END FUNCTION zbrent + END INTERFACE + INTERFACE + SUBROUTINE zrhqr(a,rtr,rti) + USE nrtype + REAL(SP), DIMENSION(:), INTENT(IN) :: a + REAL(SP), DIMENSION(:), INTENT(OUT) :: rtr,rti + END SUBROUTINE zrhqr + END INTERFACE + INTERFACE + FUNCTION zriddr(func,x1,x2,xacc) + USE nrtype + REAL(SP), INTENT(IN) :: x1,x2,xacc + REAL(SP) :: zriddr + INTERFACE + FUNCTION func(x) + USE nrtype + REAL(SP), INTENT(IN) :: x + REAL(SP) :: func + END FUNCTION func + END INTERFACE + END FUNCTION zriddr + END INTERFACE + INTERFACE + SUBROUTINE zroots(a,roots,polish) + USE nrtype + COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a + COMPLEX(SPC), DIMENSION(:), INTENT(OUT) :: roots + LOGICAL(LGT), INTENT(IN) :: polish + END SUBROUTINE zroots + END INTERFACE +END MODULE nr + + + + +MODULE nrutil + USE nrtype + IMPLICIT NONE + INTEGER(I4B), PARAMETER :: NPAR_ARTH=16,NPAR2_ARTH=8 + INTEGER(I4B), PARAMETER :: NPAR_GEOP=4,NPAR2_GEOP=2 + INTEGER(I4B), PARAMETER :: NPAR_CUMSUM=16 + INTEGER(I4B), PARAMETER :: NPAR_CUMPROD=8 + INTEGER(I4B), PARAMETER :: NPAR_POLY=8 + INTEGER(I4B), PARAMETER :: NPAR_POLYTERM=8 + INTERFACE array_copy + MODULE PROCEDURE array_copy_r, array_copy_i + END INTERFACE + INTERFACE swap + MODULE PROCEDURE swap_i,swap_r,swap_rv,swap_c, & + swap_cv,swap_cm, & + masked_swap_rs,masked_swap_rv,masked_swap_rm + END INTERFACE + INTERFACE reallocate + MODULE PROCEDURE reallocate_rv,reallocate_rm,& + reallocate_iv,reallocate_im,reallocate_hv + END INTERFACE + INTERFACE imaxloc + MODULE PROCEDURE imaxloc_r,imaxloc_i + END INTERFACE + INTERFACE assert + MODULE PROCEDURE assert1,assert2,assert3,assert4,assert_v + END INTERFACE + INTERFACE assert_eq + MODULE PROCEDURE assert_eq2,assert_eq3,assert_eq4,assert_eqn + END INTERFACE + INTERFACE arth + MODULE PROCEDURE arth_r, arth_i + END INTERFACE + INTERFACE geop + MODULE PROCEDURE geop_r, geop_i, geop_c, geop_dv + END INTERFACE + INTERFACE cumsum + MODULE PROCEDURE cumsum_r,cumsum_i + END INTERFACE + INTERFACE poly + MODULE PROCEDURE poly_rr,poly_rrv,& + poly_rc,poly_cc,poly_msk_rrv + END INTERFACE + INTERFACE poly_term + MODULE PROCEDURE poly_term_rr,poly_term_cc + END INTERFACE + INTERFACE outerprod + MODULE PROCEDURE outerprod_r + END INTERFACE + INTERFACE outerdiff + MODULE PROCEDURE outerdiff_r,outerdiff_i + END INTERFACE + INTERFACE scatter_add + MODULE PROCEDURE scatter_add_r + END INTERFACE + INTERFACE scatter_max + MODULE PROCEDURE scatter_max_r + END INTERFACE + INTERFACE diagadd + MODULE PROCEDURE diagadd_rv,diagadd_r + END INTERFACE + INTERFACE diagmult + MODULE PROCEDURE diagmult_rv,diagmult_r + END INTERFACE + INTERFACE get_diag + MODULE PROCEDURE get_diag_rv + END INTERFACE + INTERFACE put_diag + MODULE PROCEDURE put_diag_rv, put_diag_r + END INTERFACE +CONTAINS +!BL + SUBROUTINE array_copy_r(src,dest,n_copied,n_not_copied) + REAL(SP), DIMENSION(:), INTENT(IN) :: src + REAL(SP), DIMENSION(:), INTENT(OUT) :: dest + INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied + n_copied=min(size(src),size(dest)) + n_not_copied=size(src)-n_copied + dest(1:n_copied)=src(1:n_copied) + END SUBROUTINE array_copy_r +!BL + SUBROUTINE array_copy_i(src,dest,n_copied,n_not_copied) + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: src + INTEGER(I4B), DIMENSION(:), INTENT(OUT) :: dest + INTEGER(I4B), INTENT(OUT) :: n_copied, n_not_copied + n_copied=min(size(src),size(dest)) + n_not_copied=size(src)-n_copied + dest(1:n_copied)=src(1:n_copied) + END SUBROUTINE array_copy_i +!BL +!BL + SUBROUTINE swap_i(a,b) + INTEGER(I4B), INTENT(INOUT) :: a,b + INTEGER(I4B) :: dum + dum=a + a=b + b=dum + END SUBROUTINE swap_i +!BL + SUBROUTINE swap_r(a,b) + REAL(SP), INTENT(INOUT) :: a,b + REAL(SP) :: dum + dum=a + a=b + b=dum + END SUBROUTINE swap_r +!BL + SUBROUTINE swap_rv(a,b) + REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b + REAL(SP), DIMENSION(SIZE(a)) :: dum + dum=a + a=b + b=dum + END SUBROUTINE swap_rv +!BL + SUBROUTINE swap_c(a,b) + COMPLEX(SPC), INTENT(INOUT) :: a,b + COMPLEX(SPC) :: dum + dum=a + a=b + b=dum + END SUBROUTINE swap_c +!BL + SUBROUTINE swap_cv(a,b) + COMPLEX(SPC), DIMENSION(:), INTENT(INOUT) :: a,b + COMPLEX(SPC), DIMENSION(SIZE(a)) :: dum + dum=a + a=b + b=dum + END SUBROUTINE swap_cv +!BL + SUBROUTINE swap_cm(a,b) + COMPLEX(SPC), DIMENSION(:,:), INTENT(INOUT) :: a,b + COMPLEX(SPC), DIMENSION(size(a,1),size(a,2)) :: dum + dum=a + a=b + b=dum + END SUBROUTINE swap_cm +!BL + SUBROUTINE masked_swap_rs(a,b,mask) + REAL(SP), INTENT(INOUT) :: a,b + LOGICAL(LGT), INTENT(IN) :: mask + REAL(SP) :: swp + if (mask) then + swp=a + a=b + b=swp + end if + END SUBROUTINE masked_swap_rs +!BL + SUBROUTINE masked_swap_rv(a,b,mask) + REAL(SP), DIMENSION(:), INTENT(INOUT) :: a,b + LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask + REAL(SP), DIMENSION(size(a)) :: swp + where (mask) + swp=a + a=b + b=swp + end where + END SUBROUTINE masked_swap_rv +!BL + SUBROUTINE masked_swap_rm(a,b,mask) + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a,b + LOGICAL(LGT), DIMENSION(:,:), INTENT(IN) :: mask + REAL(SP), DIMENSION(size(a,1),size(a,2)) :: swp + where (mask) + swp=a + a=b + b=swp + end where + END SUBROUTINE masked_swap_rm +!BL +!BL + FUNCTION reallocate_rv(p,n) + REAL(SP), DIMENSION(:), POINTER :: p, reallocate_rv + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B) :: nold,ierr + allocate(reallocate_rv(n),stat=ierr) + if (ierr /= 0) call & + nrerror('reallocate_rv: problem in attempt to allocate memory') + if (.not. associated(p)) RETURN + nold=size(p) + reallocate_rv(1:min(nold,n))=p(1:min(nold,n)) + deallocate(p) + END FUNCTION reallocate_rv +!BL + FUNCTION reallocate_iv(p,n) + INTEGER(I4B), DIMENSION(:), POINTER :: p, reallocate_iv + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B) :: nold,ierr + allocate(reallocate_iv(n),stat=ierr) + if (ierr /= 0) call & + nrerror('reallocate_iv: problem in attempt to allocate memory') + if (.not. associated(p)) RETURN + nold=size(p) + reallocate_iv(1:min(nold,n))=p(1:min(nold,n)) + deallocate(p) + END FUNCTION reallocate_iv +!BL + FUNCTION reallocate_hv(p,n) + CHARACTER(1), DIMENSION(:), POINTER :: p, reallocate_hv + INTEGER(I4B), INTENT(IN) :: n + INTEGER(I4B) :: nold,ierr + allocate(reallocate_hv(n),stat=ierr) + if (ierr /= 0) call & + nrerror('reallocate_hv: problem in attempt to allocate memory') + if (.not. associated(p)) RETURN + nold=size(p) + reallocate_hv(1:min(nold,n))=p(1:min(nold,n)) + deallocate(p) + END FUNCTION reallocate_hv +!BL + FUNCTION reallocate_rm(p,n,m) + REAL(SP), DIMENSION(:,:), POINTER :: p, reallocate_rm + INTEGER(I4B), INTENT(IN) :: n,m + INTEGER(I4B) :: nold,mold,ierr + allocate(reallocate_rm(n,m),stat=ierr) + if (ierr /= 0) call & + nrerror('reallocate_rm: problem in attempt to allocate memory') + if (.not. associated(p)) RETURN + nold=size(p,1) + mold=size(p,2) + reallocate_rm(1:min(nold,n),1:min(mold,m))=& + p(1:min(nold,n),1:min(mold,m)) + deallocate(p) + END FUNCTION reallocate_rm +!BL + FUNCTION reallocate_im(p,n,m) + INTEGER(I4B), DIMENSION(:,:), POINTER :: p, reallocate_im + INTEGER(I4B), INTENT(IN) :: n,m + INTEGER(I4B) :: nold,mold,ierr + allocate(reallocate_im(n,m),stat=ierr) + if (ierr /= 0) call & + nrerror('reallocate_im: problem in attempt to allocate memory') + if (.not. associated(p)) RETURN + nold=size(p,1) + mold=size(p,2) + reallocate_im(1:min(nold,n),1:min(mold,m))=& + p(1:min(nold,n),1:min(mold,m)) + deallocate(p) + END FUNCTION reallocate_im +!BL + FUNCTION ifirstloc(mask) + LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask + INTEGER(I4B) :: ifirstloc + INTEGER(I4B), DIMENSION(1) :: loc + loc=maxloc(merge(1,0,mask)) + ifirstloc=loc(1) + if (.not. mask(ifirstloc)) ifirstloc=size(mask)+1 + END FUNCTION ifirstloc +!BL + FUNCTION imaxloc_r(arr) + REAL(SP), DIMENSION(:), INTENT(IN) :: arr + INTEGER(I4B) :: imaxloc_r + INTEGER(I4B), DIMENSION(1) :: imax + imax=maxloc(arr(:)) + imaxloc_r=imax(1) + END FUNCTION imaxloc_r +!BL + FUNCTION imaxloc_i(iarr) + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: iarr + INTEGER(I4B), DIMENSION(1) :: imax + INTEGER(I4B) :: imaxloc_i + imax=maxloc(iarr(:)) + imaxloc_i=imax(1) + END FUNCTION imaxloc_i +!BL + FUNCTION iminloc(arr) + REAL(SP), DIMENSION(:), INTENT(IN) :: arr + INTEGER(I4B), DIMENSION(1) :: imin + INTEGER(I4B) :: iminloc + imin=minloc(arr(:)) + iminloc=imin(1) + END FUNCTION iminloc +!BL + SUBROUTINE assert1(n1,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, INTENT(IN) :: n1 + if (.not. n1) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + STOP 'program terminated by assert1' + end if + END SUBROUTINE assert1 +!BL + SUBROUTINE assert2(n1,n2,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, INTENT(IN) :: n1,n2 + if (.not. (n1 .and. n2)) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + STOP 'program terminated by assert2' + end if + END SUBROUTINE assert2 +!BL + SUBROUTINE assert3(n1,n2,n3,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, INTENT(IN) :: n1,n2,n3 + if (.not. (n1 .and. n2 .and. n3)) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + STOP 'program terminated by assert3' + end if + END SUBROUTINE assert3 +!BL + SUBROUTINE assert4(n1,n2,n3,n4,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, INTENT(IN) :: n1,n2,n3,n4 + if (.not. (n1 .and. n2 .and. n3 .and. n4)) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + STOP 'program terminated by assert4' + end if + END SUBROUTINE assert4 +!BL + SUBROUTINE assert_v(n,string) + CHARACTER(LEN=*), INTENT(IN) :: string + LOGICAL, DIMENSION(:), INTENT(IN) :: n + if (.not. all(n)) then + write (*,*) 'nrerror: an assertion failed with this tag:', & + string + STOP 'program terminated by assert_v' + end if + END SUBROUTINE assert_v +!BL + FUNCTION assert_eq2(n1,n2,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, INTENT(IN) :: n1,n2 + INTEGER :: assert_eq2 + if (n1 == n2) then + assert_eq2=n1 + else + write (*,*) 'nrerror: an assert_eq failed with this tag:', & + string + STOP 'program terminated by assert_eq2' + end if + END FUNCTION assert_eq2 +!BL + FUNCTION assert_eq3(n1,n2,n3,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, INTENT(IN) :: n1,n2,n3 + INTEGER :: assert_eq3 + if (n1 == n2 .and. n2 == n3) then + assert_eq3=n1 + else + write (*,*) 'nrerror: an assert_eq failed with this tag:', & + string + STOP 'program terminated by assert_eq3' + end if + END FUNCTION assert_eq3 +!BL + FUNCTION assert_eq4(n1,n2,n3,n4,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, INTENT(IN) :: n1,n2,n3,n4 + INTEGER :: assert_eq4 + if (n1 == n2 .and. n2 == n3 .and. n3 == n4) then + assert_eq4=n1 + else + write (*,*) 'nrerror: an assert_eq failed with this tag:', & + string + STOP 'program terminated by assert_eq4' + end if + END FUNCTION assert_eq4 +!BL + FUNCTION assert_eqn(nn,string) + CHARACTER(LEN=*), INTENT(IN) :: string + INTEGER, DIMENSION(:), INTENT(IN) :: nn + INTEGER :: assert_eqn + if (all(nn(2:) == nn(1))) then + assert_eqn=nn(1) + else + write (*,*) 'nrerror: an assert_eq failed with this tag:', & + string + STOP 'program terminated by assert_eqn' + end if + END FUNCTION assert_eqn +!BL + SUBROUTINE nrerror(string) + CHARACTER(LEN=*), INTENT(IN) :: string + write (*,*) 'nrerror: ',string +! STOP 'program terminated by nrerror' + END SUBROUTINE nrerror +!BL + FUNCTION arth_r(first,increment,n) + REAL(SP), INTENT(IN) :: first,increment + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), DIMENSION(n) :: arth_r + INTEGER(I4B) :: k,k2 + REAL(SP) :: temp + if (n > 0) arth_r(1)=first + if (n <= NPAR_ARTH) then + do k=2,n + arth_r(k)=arth_r(k-1)+increment + end do + else + do k=2,NPAR2_ARTH + arth_r(k)=arth_r(k-1)+increment + end do + temp=increment*NPAR2_ARTH + k=NPAR2_ARTH + do + if (k >= n) exit + k2=k+k + arth_r(k+1:min(k2,n))=temp+arth_r(1:min(k,n-k)) + temp=temp+temp + k=k2 + end do + end if + END FUNCTION arth_r +!BL + FUNCTION arth_i(first,increment,n) + INTEGER(I4B), INTENT(IN) :: first,increment,n + INTEGER(I4B), DIMENSION(n) :: arth_i + INTEGER(I4B) :: k,k2,temp + if (n > 0) arth_i(1)=first + if (n <= NPAR_ARTH) then + do k=2,n + arth_i(k)=arth_i(k-1)+increment + end do + else + do k=2,NPAR2_ARTH + arth_i(k)=arth_i(k-1)+increment + end do + temp=increment*NPAR2_ARTH + k=NPAR2_ARTH + do + if (k >= n) exit + k2=k+k + arth_i(k+1:min(k2,n))=temp+arth_i(1:min(k,n-k)) + temp=temp+temp + k=k2 + end do + end if + END FUNCTION arth_i +!BL +!BL + FUNCTION geop_r(first,factor,n) + REAL(SP), INTENT(IN) :: first,factor + INTEGER(I4B), INTENT(IN) :: n + REAL(SP), DIMENSION(n) :: geop_r + INTEGER(I4B) :: k,k2 + REAL(SP) :: temp + if (n > 0) geop_r(1)=first + if (n <= NPAR_GEOP) then + do k=2,n + geop_r(k)=geop_r(k-1)*factor + end do + else + do k=2,NPAR2_GEOP + geop_r(k)=geop_r(k-1)*factor + end do + temp=factor**NPAR2_GEOP + k=NPAR2_GEOP + do + if (k >= n) exit + k2=k+k + geop_r(k+1:min(k2,n))=temp*geop_r(1:min(k,n-k)) + temp=temp*temp + k=k2 + end do + end if + END FUNCTION geop_r +!BL + FUNCTION geop_i(first,factor,n) + INTEGER(I4B), INTENT(IN) :: first,factor,n + INTEGER(I4B), DIMENSION(n) :: geop_i + INTEGER(I4B) :: k,k2,temp + if (n > 0) geop_i(1)=first + if (n <= NPAR_GEOP) then + do k=2,n + geop_i(k)=geop_i(k-1)*factor + end do + else + do k=2,NPAR2_GEOP + geop_i(k)=geop_i(k-1)*factor + end do + temp=factor**NPAR2_GEOP + k=NPAR2_GEOP + do + if (k >= n) exit + k2=k+k + geop_i(k+1:min(k2,n))=temp*geop_i(1:min(k,n-k)) + temp=temp*temp + k=k2 + end do + end if + END FUNCTION geop_i +!BL + FUNCTION geop_c(first,factor,n) + COMPLEX(SP), INTENT(IN) :: first,factor + INTEGER(I4B), INTENT(IN) :: n + COMPLEX(SP), DIMENSION(n) :: geop_c + INTEGER(I4B) :: k,k2 + COMPLEX(SP) :: temp + if (n > 0) geop_c(1)=first + if (n <= NPAR_GEOP) then + do k=2,n + geop_c(k)=geop_c(k-1)*factor + end do + else + do k=2,NPAR2_GEOP + geop_c(k)=geop_c(k-1)*factor + end do + temp=factor**NPAR2_GEOP + k=NPAR2_GEOP + do + if (k >= n) exit + k2=k+k + geop_c(k+1:min(k2,n))=temp*geop_c(1:min(k,n-k)) + temp=temp*temp + k=k2 + end do + end if + END FUNCTION geop_c +!BL + FUNCTION geop_dv(first,factor,n) + REAL(DP), DIMENSION(:), INTENT(IN) :: first,factor + INTEGER(I4B), INTENT(IN) :: n + REAL(DP), DIMENSION(size(first),n) :: geop_dv + INTEGER(I4B) :: k,k2 + REAL(DP), DIMENSION(size(first)) :: temp + if (n > 0) geop_dv(:,1)=first(:) + if (n <= NPAR_GEOP) then + do k=2,n + geop_dv(:,k)=geop_dv(:,k-1)*factor(:) + end do + else + do k=2,NPAR2_GEOP + geop_dv(:,k)=geop_dv(:,k-1)*factor(:) + end do + temp=factor**NPAR2_GEOP + k=NPAR2_GEOP + do + if (k >= n) exit + k2=k+k + geop_dv(:,k+1:min(k2,n))=geop_dv(:,1:min(k,n-k))*& + spread(temp,2,size(geop_dv(:,1:min(k,n-k)),2)) + temp=temp*temp + k=k2 + end do + end if + END FUNCTION geop_dv +!BL +!BL + RECURSIVE FUNCTION cumsum_r(arr,seed) RESULT(ans) + REAL(SP), DIMENSION(:), INTENT(IN) :: arr + REAL(SP), OPTIONAL, INTENT(IN) :: seed + REAL(SP), DIMENSION(size(arr)) :: ans + INTEGER(I4B) :: n,j + REAL(SP) :: sd + n=size(arr) + if (n == 0_i4b) RETURN + sd=0.0_sp + if (present(seed)) sd=seed + ans(1)=arr(1)+sd + if (n < NPAR_CUMSUM) then + do j=2,n + ans(j)=ans(j-1)+arr(j) + end do + else + ans(2:n:2)=cumsum_r(arr(2:n:2)+arr(1:n-1:2),sd) + ans(3:n:2)=ans(2:n-1:2)+arr(3:n:2) + end if + END FUNCTION cumsum_r +!BL + RECURSIVE FUNCTION cumsum_i(arr,seed) RESULT(ans) + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: arr + INTEGER(I4B), OPTIONAL, INTENT(IN) :: seed + INTEGER(I4B), DIMENSION(size(arr)) :: ans + INTEGER(I4B) :: n,j,sd + n=size(arr) + if (n == 0_i4b) RETURN + sd=0_i4b + if (present(seed)) sd=seed + ans(1)=arr(1)+sd + if (n < NPAR_CUMSUM) then + do j=2,n + ans(j)=ans(j-1)+arr(j) + end do + else + ans(2:n:2)=cumsum_i(arr(2:n:2)+arr(1:n-1:2),sd) + ans(3:n:2)=ans(2:n-1:2)+arr(3:n:2) + end if + END FUNCTION cumsum_i +!BL +!BL + RECURSIVE FUNCTION cumprod(arr,seed) RESULT(ans) + REAL(SP), DIMENSION(:), INTENT(IN) :: arr + REAL(SP), OPTIONAL, INTENT(IN) :: seed + REAL(SP), DIMENSION(size(arr)) :: ans + INTEGER(I4B) :: n,j + REAL(SP) :: sd + n=size(arr) + if (n == 0_i4b) RETURN + sd=1.0_sp + if (present(seed)) sd=seed + ans(1)=arr(1)*sd + if (n < NPAR_CUMPROD) then + do j=2,n + ans(j)=ans(j-1)*arr(j) + end do + else + ans(2:n:2)=cumprod(arr(2:n:2)*arr(1:n-1:2),sd) + ans(3:n:2)=ans(2:n-1:2)*arr(3:n:2) + end if + END FUNCTION cumprod +!BL +!BL + FUNCTION poly_rr(x,coeffs) + REAL(SP), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs + REAL(SP) :: poly_rr + REAL(SP) :: pow + REAL(SP), DIMENSION(:), ALLOCATABLE :: vec + INTEGER(I4B) :: i,n,nn + n=size(coeffs) + if (n <= 0) then + poly_rr=0.0_sp + else if (n < NPAR_POLY) then + poly_rr=coeffs(n) + do i=n-1,1,-1 + poly_rr=x*poly_rr+coeffs(i) + end do + else + allocate(vec(n+1)) + pow=x + vec(1:n)=coeffs + do + vec(n+1)=0.0_sp + nn=ishft(n+1,-1) + vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) + if (nn == 1) exit + pow=pow*pow + n=nn + end do + poly_rr=vec(1) + deallocate(vec) + end if + END FUNCTION poly_rr +!BL + FUNCTION poly_rc(x,coeffs) + COMPLEX(SPC), INTENT(IN) :: x + REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs + COMPLEX(SPC) :: poly_rc + COMPLEX(SPC) :: pow + COMPLEX(SPC), DIMENSION(:), ALLOCATABLE :: vec + INTEGER(I4B) :: i,n,nn + n=size(coeffs) + if (n <= 0) then + poly_rc=0.0_sp + else if (n < NPAR_POLY) then + poly_rc=coeffs(n) + do i=n-1,1,-1 + poly_rc=x*poly_rc+coeffs(i) + end do + else + allocate(vec(n+1)) + pow=x + vec(1:n)=coeffs + do + vec(n+1)=0.0_sp + nn=ishft(n+1,-1) + vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) + if (nn == 1) exit + pow=pow*pow + n=nn + end do + poly_rc=vec(1) + deallocate(vec) + end if + END FUNCTION poly_rc +!BL + FUNCTION poly_cc(x,coeffs) + COMPLEX(SPC), INTENT(IN) :: x + COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: coeffs + COMPLEX(SPC) :: poly_cc + COMPLEX(SPC) :: pow + COMPLEX(SPC), DIMENSION(:), ALLOCATABLE :: vec + INTEGER(I4B) :: i,n,nn + n=size(coeffs) + if (n <= 0) then + poly_cc=0.0_sp + else if (n < NPAR_POLY) then + poly_cc=coeffs(n) + do i=n-1,1,-1 + poly_cc=x*poly_cc+coeffs(i) + end do + else + allocate(vec(n+1)) + pow=x + vec(1:n)=coeffs + do + vec(n+1)=0.0_sp + nn=ishft(n+1,-1) + vec(1:nn)=vec(1:n:2)+pow*vec(2:n+1:2) + if (nn == 1) exit + pow=pow*pow + n=nn + end do + poly_cc=vec(1) + deallocate(vec) + end if + END FUNCTION poly_cc +!BL + FUNCTION poly_rrv(x,coeffs) + REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs,x + REAL(SP), DIMENSION(size(x)) :: poly_rrv + INTEGER(I4B) :: i,n,m + m=size(coeffs) + n=size(x) + if (m <= 0) then + poly_rrv=0.0_sp + else if (m < n .or. m < NPAR_POLY) then + poly_rrv=coeffs(m) + do i=m-1,1,-1 + poly_rrv=x*poly_rrv+coeffs(i) + end do + else + do i=1,n + poly_rrv(i)=poly_rr(x(i),coeffs) + end do + end if + END FUNCTION poly_rrv +!BL + FUNCTION poly_msk_rrv(x,coeffs,mask) + REAL(SP), DIMENSION(:), INTENT(IN) :: coeffs,x + LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: mask + REAL(SP), DIMENSION(size(x)) :: poly_msk_rrv + poly_msk_rrv=unpack(poly_rrv(pack(x,mask),coeffs),mask,0.0_sp) + END FUNCTION poly_msk_rrv +!BL +!BL +!BL + RECURSIVE FUNCTION poly_term_rr(a,b) RESULT(u) + REAL(SP), DIMENSION(:), INTENT(IN) :: a + REAL(SP), INTENT(IN) :: b + REAL(SP), DIMENSION(size(a)) :: u + INTEGER(I4B) :: n,j + n=size(a) + if (n <= 0) RETURN + u(1)=a(1) + if (n < NPAR_POLYTERM) then + do j=2,n + u(j)=a(j)+b*u(j-1) + end do + else + u(2:n:2)=poly_term_rr(a(2:n:2)+a(1:n-1:2)*b,b*b) + u(3:n:2)=a(3:n:2)+b*u(2:n-1:2) + end if + END FUNCTION poly_term_rr +!BL + RECURSIVE FUNCTION poly_term_cc(a,b) RESULT(u) + COMPLEX(SPC), DIMENSION(:), INTENT(IN) :: a + COMPLEX(SPC), INTENT(IN) :: b + COMPLEX(SPC), DIMENSION(size(a)) :: u + INTEGER(I4B) :: n,j + n=size(a) + if (n <= 0) RETURN + u(1)=a(1) + if (n < NPAR_POLYTERM) then + do j=2,n + u(j)=a(j)+b*u(j-1) + end do + else + u(2:n:2)=poly_term_cc(a(2:n:2)+a(1:n-1:2)*b,b*b) + u(3:n:2)=a(3:n:2)+b*u(2:n-1:2) + end if + END FUNCTION poly_term_cc +!BL +!BL + FUNCTION zroots_unity(n,nn) + INTEGER(I4B), INTENT(IN) :: n,nn + COMPLEX(SPC), DIMENSION(nn) :: zroots_unity + INTEGER(I4B) :: k + REAL(SP) :: theta + zroots_unity(1)=1.0 + theta=TWOPI/n + k=1 + do + if (k >= nn) exit + zroots_unity(k+1)=cmplx(cos(k*theta),sin(k*theta),SPC) + zroots_unity(k+2:min(2*k,nn))=zroots_unity(k+1)*& + zroots_unity(2:min(k,nn-k)) + k=2*k + end do + END FUNCTION zroots_unity +!BL + FUNCTION outerprod_r(a,b) + REAL(SP), DIMENSION(:), INTENT(IN) :: a,b + REAL(SP), DIMENSION(size(a),size(b)) :: outerprod_r + outerprod_r = spread(a,dim=2,ncopies=size(b)) * & + spread(b,dim=1,ncopies=size(a)) + END FUNCTION outerprod_r +!BL +!BL + FUNCTION outerdiv(a,b) + REAL(SP), DIMENSION(:), INTENT(IN) :: a,b + REAL(SP), DIMENSION(size(a),size(b)) :: outerdiv + outerdiv = spread(a,dim=2,ncopies=size(b)) / & + spread(b,dim=1,ncopies=size(a)) + END FUNCTION outerdiv +!BL + FUNCTION outersum(a,b) + REAL(SP), DIMENSION(:), INTENT(IN) :: a,b + REAL(SP), DIMENSION(size(a),size(b)) :: outersum + outersum = spread(a,dim=2,ncopies=size(b)) + & + spread(b,dim=1,ncopies=size(a)) + END FUNCTION outersum +!BL + FUNCTION outerdiff_r(a,b) + REAL(SP), DIMENSION(:), INTENT(IN) :: a,b + REAL(SP), DIMENSION(size(a),size(b)) :: outerdiff_r + outerdiff_r = spread(a,dim=2,ncopies=size(b)) - & + spread(b,dim=1,ncopies=size(a)) + END FUNCTION outerdiff_r +!BL + FUNCTION outerdiff_d(a,b) + REAL(DP), DIMENSION(:), INTENT(IN) :: a,b + REAL(DP), DIMENSION(size(a),size(b)) :: outerdiff_d + outerdiff_d = spread(a,dim=2,ncopies=size(b)) - & + spread(b,dim=1,ncopies=size(a)) + END FUNCTION outerdiff_d +!BL + FUNCTION outerdiff_i(a,b) + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: a,b + INTEGER(I4B), DIMENSION(size(a),size(b)) :: outerdiff_i + outerdiff_i = spread(a,dim=2,ncopies=size(b)) - & + spread(b,dim=1,ncopies=size(a)) + END FUNCTION outerdiff_i +!BL + FUNCTION outerand(a,b) + LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: a,b + LOGICAL(LGT), DIMENSION(size(a),size(b)) :: outerand + outerand = spread(a,dim=2,ncopies=size(b)) .and. & + spread(b,dim=1,ncopies=size(a)) + END FUNCTION outerand +!BL + SUBROUTINE scatter_add_r(dest,source,dest_index) + REAL(SP), DIMENSION(:), INTENT(OUT) :: dest + REAL(SP), DIMENSION(:), INTENT(IN) :: source + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index + INTEGER(I4B) :: m,n,j,i + n=assert_eq2(size(source),size(dest_index),'scatter_add_r') + m=size(dest) + do j=1,n + i=dest_index(j) + if (i > 0 .and. i <= m) dest(i)=dest(i)+source(j) + end do + END SUBROUTINE scatter_add_r + SUBROUTINE scatter_max_r(dest,source,dest_index) + REAL(SP), DIMENSION(:), INTENT(OUT) :: dest + REAL(SP), DIMENSION(:), INTENT(IN) :: source + INTEGER(I4B), DIMENSION(:), INTENT(IN) :: dest_index + INTEGER(I4B) :: m,n,j,i + n=assert_eq2(size(source),size(dest_index),'scatter_max_r') + m=size(dest) + do j=1,n + i=dest_index(j) + if (i > 0 .and. i <= m) dest(i)=max(dest(i),source(j)) + end do + END SUBROUTINE scatter_max_r +!BL + SUBROUTINE diagadd_rv(mat,diag) + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat + REAL(SP), DIMENSION(:), INTENT(IN) :: diag + INTEGER(I4B) :: j,n + n = assert_eq2(size(diag),min(size(mat,1),size(mat,2)),'diagadd_rv') + do j=1,n + mat(j,j)=mat(j,j)+diag(j) + end do + END SUBROUTINE diagadd_rv +!BL + SUBROUTINE diagadd_r(mat,diag) + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat + REAL(SP), INTENT(IN) :: diag + INTEGER(I4B) :: j,n + n = min(size(mat,1),size(mat,2)) + do j=1,n + mat(j,j)=mat(j,j)+diag + end do + END SUBROUTINE diagadd_r +!BL + SUBROUTINE diagmult_rv(mat,diag) + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat + REAL(SP), DIMENSION(:), INTENT(IN) :: diag + INTEGER(I4B) :: j,n + n = assert_eq2(size(diag),min(size(mat,1),size(mat,2)),'diagmult_rv') + do j=1,n + mat(j,j)=mat(j,j)*diag(j) + end do + END SUBROUTINE diagmult_rv +!BL + SUBROUTINE diagmult_r(mat,diag) + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat + REAL(SP), INTENT(IN) :: diag + INTEGER(I4B) :: j,n + n = min(size(mat,1),size(mat,2)) + do j=1,n + mat(j,j)=mat(j,j)*diag + end do + END SUBROUTINE diagmult_r +!BL + FUNCTION get_diag_rv(mat) + REAL(SP), DIMENSION(:,:), INTENT(IN) :: mat + REAL(SP), DIMENSION(size(mat,1)) :: get_diag_rv + INTEGER(I4B) :: j + j=assert_eq2(size(mat,1),size(mat,2),'get_diag_rv') + do j=1,size(mat,1) + get_diag_rv(j)=mat(j,j) + end do + END FUNCTION get_diag_rv +!BL +!BL + SUBROUTINE put_diag_rv(diagv,mat) + REAL(SP), DIMENSION(:), INTENT(IN) :: diagv + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat + INTEGER(I4B) :: j,n + n=assert_eq2(size(diagv),min(size(mat,1),size(mat,2)),'put_diag_rv') + do j=1,n + mat(j,j)=diagv(j) + end do + END SUBROUTINE put_diag_rv +!BL + SUBROUTINE put_diag_r(scal,mat) + REAL(SP), INTENT(IN) :: scal + REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: mat + INTEGER(I4B) :: j,n + n = min(size(mat,1),size(mat,2)) + do j=1,n + mat(j,j)=scal + end do + END SUBROUTINE put_diag_r +!BL + SUBROUTINE unit_matrix(mat) + REAL(SP), DIMENSION(:,:), INTENT(OUT) :: mat + INTEGER(I4B) :: i,n + n=min(size(mat,1),size(mat,2)) + mat(:,:)=0.0_sp + do i=1,n + mat(i,i)=1.0_sp + end do + END SUBROUTINE unit_matrix +!BL + FUNCTION upper_triangle(j,k,extra) + INTEGER(I4B), INTENT(IN) :: j,k + INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra + LOGICAL(LGT), DIMENSION(j,k) :: upper_triangle + INTEGER(I4B) :: n + n=0 + if (present(extra)) n=extra + upper_triangle=(outerdiff(arth_i(1,1,j),arth_i(1,1,k)) < n) + END FUNCTION upper_triangle +!BL + FUNCTION lower_triangle(j,k,extra) + INTEGER(I4B), INTENT(IN) :: j,k + INTEGER(I4B), OPTIONAL, INTENT(IN) :: extra + LOGICAL(LGT), DIMENSION(j,k) :: lower_triangle + INTEGER(I4B) :: n + n=0 + if (present(extra)) n=extra + lower_triangle=(outerdiff(arth_i(1,1,j),arth_i(1,1,k)) > -n) + END FUNCTION lower_triangle +!BL + FUNCTION vabs(v) + REAL(SP), DIMENSION(:), INTENT(IN) :: v + REAL(SP) :: vabs + vabs=sqrt(dot_product(v,v)) + END FUNCTION vabs +!BL +END MODULE nrutil + +!******************************* A U T O S U R F ********************************* +!=================================================================================== +!----------------------------------------------------------------------------------- +!- - +!- AUTOSURF Package: A set of programs for the automated construction - +!- of Potential Energy Surfaces on van der Waals systems - +!- - +!----------------------------------------------------------------------------------- +!=================================================================================== +!*********************************************************************************** +!- "POTEN_rigidXD": SUBROUTINES for ... - +!- ver. 3.1 - +!----------------------------------------------------------------------------------- +!- Input files: "input-AUTOSURF-PES.dat" & "PES-file" - +!- - +!*********************************************************************************** +!! !! +!! Fitted range: rmin(1) < R < rmax(1), as specified in the input file. !! +!! Jac3(1) is R, the distance between centers of mass (in Angstroms). !! improve... XDIM +!! Jac3(2) and Jac3(3) are cos(theta1) and cos(theta2) and range from (-1,1). !! +!! Jac3(4) is the dihedral angle, in radians, with range: (0,2pi). !! +!! NAME1 is the name of the PES-file generated by AUTOSURF-PES. !! +!! Subroutine PES(jac3,V,NAME1) returns the potential "V". !! +!! Output energy is in kcal/mol. !! +!! !! +!*********************************************************************************** + +SUBROUTINE PES(jac3,V,NAME1,xpes,xverb) +! xpes = 0 --> func_actual(xi) +! xpes = 1 --> func_actual_lower(xi) +! xpes = 2 --> func_actual_min(xi) +! xpes = 3 --> func_actual_seed(xi) + +use dynamic_parameters +!----------------------------------------------------------------------------------- +implicit none + character (len=40), INTENT(IN) :: NAME1 + integer, INTENT(IN) :: xpes,xverb + real*8, INTENT(IN) :: jac3(4) + real*8, INTENT(OUT) :: V + character (len=160) :: line + integer :: i,j,initflag,nline,ncont1 + real*8 :: xi(4),xlr(4),temp,temp2,temp3,pii,V1,V2,SS,x1,x2,x3,x4,th1,th2!,XCONVE1 + real*8,allocatable :: cart3(:),internal(:,:),grad_int(:,:),gradients(:) + logical :: logica1 + real*8,parameter :: XCONVE1=349.755088236337d0 + save initflag + data initflag /1/ +!----------------------------------------------------------------------------------- +! Interface blocks +!----------------------------------------------------------------------------------- +INTERFACE! Energy of largest basis and high-level ab initio + FUNCTION func_actual(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual + END FUNCTION func_actual +end interface +INTERFACE! Energy of secondary basis and high-level ab initio + FUNCTION func_actual_lower(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_lower + END FUNCTION func_actual_lower +end interface +INTERFACE! Energy of minimal basis and high-level ab initio + FUNCTION func_actual_min(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_min + END FUNCTION func_actual_min +end interface +INTERFACE! Energy of minimal basis and low-level ab initio + FUNCTION func_actual_seed(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_seed + END FUNCTION func_actual_seed +END INTERFACE +!----------------------------------------------------------------------------------- +!----------------------------------------------------------------------------------- + +pii=dacos(-1d0) +nline=scan(NAME1,' ')-1 +!XCONVE1=219474.6313702d0/(4.359744650D-18/4184*6.022140857D23) + +! check if PES file exists... +inquire(file=NAME1(1:nline),exist=logica1) +if(.not.logica1)then + write(*,*) + write(*,*)'ERROR: The file: ',NAME1(1:nline),' does not exist !! ' + stop +endif + +!*********************************************************************************** +! INITIALIZATION +!*********************************************************************************** +IF(initflag==1)THEN! initialize + + !# PES INFORMATION: + OPEN (UNIT=652, FILE=NAME1(1:nline), FORM='UNFORMATTED', ACCESS='SEQUENTIAL',POSITION='REWIND') + + ! general definitions: + read(652)XSYS + read(652)XDIM + read(652)XMAG + read(652)XBAS + read(652)XDIST + + ! input file: + read(652)nlinput + do i=1,nlinput + read(652)line + enddo + + ! general info: + read(652)count3 + read(652)ab_flag,ab_flag2 + read(652)dist_tol + !dist_tol=0.1 + read(652)maxpoints + allocate(rmax(XDIM),rmin(XDIM),rmaxNS(XDIM),rminNS(XDIM),rmaxXS(XDIM),rminXS(XDIM)) + read(652)rmax,rmaxNS,rminXS + read(652)rmin,rminNS,rmaxXS + read(652)Max_E + !Max_E=Max_E+600.0d0 + read(652)low_grid + read(652)count_seed + + ! distance metric + read(652)epss + read(652)zz + read(652)zz_low + read(652)zz4 + read(652)W_a + + ! symmetry + if (XDIM==2) then + read(652)flip + symparts=flip+1 + elseif (XDIM==3) then + read(652)nfold + read(652)flip + read(652)reflect + symparts=((flip+1)*(reflect+1)) + elseif (XDIM==4) then + read(652)exch + read(652)flip1 + read(652)flip2 + symparts=((exch+1)*(flip1+1)*(flip2+1))*2 + endif + + ! fragments-information + read(652)natom1 + read(652)natom2 + natom=natom1+natom2 + nbdist=natom*(natom-1)/2 + allocate(symb(natom),mass(natom)) + read(652)symb + read(652)mass + allocate(ref1(3*natom1),ref2(3*natom2),bdist(nbdist),cart(3*(natom))) + read(652)ref1 + read(652)ref2 + + ! basis set + read(652)alpha,xbeta + allocate(order(XDIM),order0(XDIM),order_min(XDIM)) + read(652)order,order0 + read(652)order_min + allocate(order_low(XDIM),order_low0(XDIM)) + read(652)order_low,order_low0 + ! calculate the size of high-degree basis set: + call basis_size_rigidXD(order,order0,XDIM,XBAS,basis_1) + ! calculate the size of lower-degree basis set: + call basis_size_rigidXD(order-1,order0,XDIM,XBAS,basis_2) + ! calculate the size of minimal basis set: + call basis_size_rigidXD(order_min,order0,XDIM,XBAS,basis_3) + ! calculate the size of the basis set to fit the LOW-GRID: + if (low_grid>0) call basis_size_rigidXD(order_low,order_low0,XDIM,XBAS,basis_4) + + ! coefficients: + allocate(b2(basis_1,symparts*maxpoints),b2_lower(basis_2,symparts*maxpoints)) + allocate(b2_minimal(basis_3,symparts*maxpoints),d(symparts*maxpoints)) + allocate(coords(symparts*maxpoints,XDIM)) + b2=0d0 + b2_lower=0d0 + b2_minimal=0d0 + d=0d0 + coords=0d0 + do i=1,count3 + read(652) b2(:,i) + enddo + do i=1,count3 + read(652) b2_lower(:,i) + enddo + do i=1,count3 + read(652) b2_minimal(:,i) + enddo + do i=1,count3 + read(652) d(i) + enddo + do i=1,count3 + read(652) coords(i,:) + enddo + if (low_grid>0) then + allocate(b2_seed(basis_4,maxpoints*symparts),d_seed(maxpoints*symparts)) + allocate(coords_seed(symparts*maxpoints,XDIM)) + b2_seed=0d0 + d_seed=0d0 + coords_seed=0d0 + read(652) Max_E_seed + do i=1,count_seed + read(652) b2_seed(:,i) + enddo + do i=1,count_seed + read(652) d_seed(i) + enddo + do i=1,count_seed + read(652) coords_seed(i,:) + enddo + endif + close(652) + + initflag=2 + + ! set asymptotic energy (ass) + xi=0d0 + CALL Long_Range_Potential(xi,ass) + !ass=-129596.39668878d0 + +ENDIF +!*********************************************************************************** +allocate(internal(symparts,XDIM),grad_int(symparts,XDIM),gradients(3*(natom1+natom2))) +allocate(cart3(3*(natom))) +xi=jac3 +xlr=jac3 +xlr(2)=dacos(xi(2))*180d0/pii +xlr(3)=dacos(xi(3))*180d0/pii +dist_flag=0 + +IF (XSYS==1) THEN! (two rigid-fragments systems) + + ! Make sure angular coordinates are in the appropriate range + if (XDIM==2) then + ! cos(TH) always from -1 to 1 + if(xi(2)>1.d0)then + xi(2)=2.d0-xi(2) + endif + if(xi(2)<-1.d0)then + xi(2)=-2.d0-xi(2) + endif + if (flip==1) xi(2)=dabs(xi(2)) + elseif (XDIM==3) then + ! cos(TH) always from -1 to 1 + if(xi(2)>1.d0)then + xi(2)=2.d0-xi(2) + endif + if(xi(2)<-1.d0)then + xi(2)=-2.d0-xi(2) + endif + if (flip==1) xi(2)=dabs(xi(2)) + ! PHI=xi(3) always from -pi to pi + xi(3)=xi(3)*dble(nfold) + 100 continue + if(xi(3)>180.d0)then + xi(3)=xi(3)-360.d0 + if (xi(3)>180.d0) goto 100 + endif + if(xi(3)<-180.d0)then + xi(3)=xi(3)+360.d0 + if (xi(3)<-180.d0) goto 100 + endif + if (reflect==1) xi(3)=dabs(xi(3)) + xi(3)=xi(3)*pii/180.d0 + elseif (XDIM==4) then + ! cos(TH1) always from -1 to 1 + if(xi(2)>1d0)then + xi(2)=2d0-xi(2) + endif + if(xi(2)<-1d0)then + xi(2)=-2d0-xi(2) + endif + ! cos(TH2) always from -1 to 1 + if(xi(3)>1d0)then + xi(3)=2d0-xi(3) + endif + if(xi(3)<-1d0)then + xi(3)=-2d0-xi(3) + endif + ! PHI=xi(4) always from -pi to pi + 200 continue + if(xi(4)>180.d0)then + xi(4)=xi(4)-360.d0 + if (xi(4)>180.d0) goto 200 + endif + if(xi(4)<-180.d0)then + xi(4)=xi(4)+360.d0 + if (xi(4)<-180.d0) goto 200 + endif + ! xi(4)=dabs(xi(4))*pii/180.d0 !! check !! + xi(4)=xi(4)*pii/180.d0 + endif + + ! Make sure angular coordinates are in the minimal symmetry sub-space + if (symparts==1) goto 666 + call symmetry(xi,dcart,internal,grad_int,ab_flag) + do i=1,symparts + ncont1=0 + !write(6,*)internal(i,:) + do j=1,XDIM + if ((internal(i,j)>=rminXS(j)).and.(internal(i,j)<=rmaxXS(j))) ncont1=ncont1+1 + !write(6,*)i,j,ncont1,symparts + enddo + if (ncont1==XDIM) then + xi(:)=internal(i,:) + goto 666 + endif + enddo + 666 continue + + !write(6,*)'testing',xi + + ! set V to the maximum allowed energy if.. + !.. coordinate R is outside fitted range + if(xi(1)rmax(1)) then + V1=0.0d0 + goto 667 + endif + if(initflag==2)initflag=3 + !.. any pair of atoms are too close + call INT_Cart(cart3,xi) + call cart_to_bdist_inter(cart3,natom1,natom2,dist_tol,dist_flag) + if(dist_flag==1) then + if (xverb==1) write(*,*)'"bdist" less than "distol" (atoms too close)',xi,dist_tol + goto 10 + endif + !.. if estimated V for low-PES is higher than "Max_E_seed" + temp3=0d0 + if(low_grid>0)then + temp3=func_actual_seed(xi) + if (temp3>Max_E_seed) dist_flag=1 + if (dist_flag==1) then + if (xverb==1) write(*,*) 'hit ceiling (low grid)' + goto 10 + endif + if (xpes==3) goto 10 + endif + !.. if estimated V for min-PES is higher than "Max_E" + if (subzero==0) then + temp2=func_actual_min(xi) + if (temp2>Max_E) dist_flag=1 + else + temp2=func_actual_min(xi)+temp3 + if (temp2>Max_E) dist_flag=1 + endif + if(dist_flag==1)then + if (xverb==1) write(*,*) 'hit ceiling (func_actual_min)' + goto 10 + endif + if (xpes==2) goto 10 + !.. if estimated V for high-PES is higher than "Max_E" + if(subzero==0)then + temp=func_actual(xi) + if (temp>Max_E) dist_flag=1 + else + temp=func_actual(xi)+temp3 + if (temp>Max_E) dist_flag=1 + endif + if(dist_flag==1)then + if (xverb==1) write(*,*) 'hit ceiling (func_actual)',xi + goto 10 + endif + +10 if (dist_flag==1) then + if (xpes==3) then + V=Max_E_seed-ass_seed + else + V=Max_E-ass + endif + !return + else + if (xpes==3) then + V=temp3-ass_seed + elseif (xpes==2) then + V=temp2-ass + elseif (xpes==1) then + if (subzero==0) V=func_actual_lower(xi)-ass + if (subzero==1) V=func_actual_lower(xi)+temp3-ass-ass_seed !! check!! + elseif (xpes==0) then + V=temp-ass + endif + !return + endif + +ENDIF + +!V1=(V-ass) +V1=V*XCONVE1 +!V=V*XCONVE1 +!return +667 continue + +CALL Long_Range_Potential(xlr,V2) +!CALL Long_Range_Potential(xi(1),dacos(xi(2))*180d0/pii,dacos(xi(3))*180d0/pii,xi(4)*180d0/pii,V2) +!CALL Long_Range_Potential(jac3(1),jac3(2),jac3(3),jac3(4),V2) + +! TANH parameters +x1=9d0 ! center +x2=1.5d0 ! width + +SS=(1d0-dtanh(x2*(xi(1)-x1)))/2d0 +V=SS*V1+(1d0-SS)*V2 +!write(*,*)V,V1,V2,SS +return + +END SUBROUTINE PES + + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! s y m m e t r y +! ---------------------------------------------------------------------------------- +! Known +! +! *** Input *** +! int_temp <-- internal coordinates +! gradients <-- gradients +! flag <-- Type of calculation: 1=single point energies, 2= also gradients +! +! *** Output *** +! internal <-- internal coordinates for all symmetry partners +! grad_int <-- gradients for all symmetry partners + +subroutine symmetry(int_temp,gradients,internal,grad_int,flag) + + use dynamic_parameters + implicit none + real*8 :: internal(symparts,XDIM),int_temp(XDIM),grad_temp(XDIM) + real*8 :: grad_int(symparts,XDIM),gradients(3*(natom1+natom2)) + real*8 :: bmat(3*(natom1+natom2),XDIM) + integer :: i,flag + + IF (XSYS==1) THEN + if (XDIM==1) then + internal(1,:)=int_temp + if(flag==2)grad_int(1,:)=gradients + elseif (XDIM==2) then + if (XBAS==0) then + do i=1,symparts + internal(i,:)=int_temp(:) + if(flag==2)grad_int(i,:)=gradients(:) + enddo + if(flip>0)then + internal(2,2)=-int_temp(2) + if(flag==2)grad_int(2,2)=-gradients(2) + endif + elseif (XBAS==1) then + internal(1,:)=int_temp + if(flag==2)grad_int(1,:)=gradients + endif + elseif (XDIM==3) then + if (flag==2) then + call dcart_dint(int_temp,natom1,natom2,bMat,XDIM) + grad_temp=matmul(transpose(bMat),gradients) + endif + call perm_int3D(int_temp,grad_temp,internal,grad_int,flip,reflect,natom1,symparts,flag,XMAG) + elseif (XDIM==4) then + if (flag==2) then + call dcart_dint(int_temp,natom1,natom2,bMat,XDIM) + grad_temp=matmul(transpose(bMat),gradients) + endif + call perm_int4D(int_temp,grad_temp,internal,grad_int,exch,flip1,flip2,natom1,natom2,flag,XMAG) + endif + ENDIF + +return +end subroutine symmetry + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! p e r m _ i n t 3 D +! ---------------------------------------------------------------------------------- +! Known +! +! *** Input *** +! int_temp <-- internal coordinates +! grad_temp <-- gradients +! mass <-- Masses of all the atom in the system +! ref1 <-- Cartesian coordinates of all the nuclei in the molecule +! natom1 <-- Number of atoms in the molecule +! flip <-- is the molecule symmetric with respect to the XY plane? 1=yes, 0=no +! reflect <-- is the molecule symmetric with respect to the XZ plane? 1=yes, 0=no +! symparts <-- number of symmetry partners to be included in the fit +! flag <-- Type of calculation: 1=single point energies, 2= also gradients +! +! *** Output *** +! internal <-- internal coordinates for all symmetry partners +! grad_int <-- gradients ... + +subroutine perm_int3D(int_temp,grad_temp,internal,grad_int,flip,reflect,natom1,symparts,flag,XMAG) + + implicit none + integer :: i,j,k,exch,flip,reflect,natom1,symparts,flag,XMAG + real*8 :: pii + real*8 :: int_temp(3),grad_temp(3),internal(symparts,3),grad_int(symparts,3) + + pii=dacos(-1d0) + + IF (XMAG==1) THEN + + do i=1,symparts + internal(i,:)=int_temp(:) + if(flag==2)grad_int(i,:)=grad_temp(:) + enddo + + ! Include all symmetry permutations: + + if(flip>0)then + internal(2,2)=-int_temp(2) + if(flag==2)grad_int(2,2)=-grad_temp(2) + if(reflect>0)then + internal(3,3)=-int_temp(3) + if(flag==2)grad_int(3,3)=-grad_temp(3) + internal(4,:)=internal(2,:) + if(flag==2)grad_int(4,:)=grad_int(2,:) + internal(4,3)=-int_temp(3) + if(flag==2)grad_int(4,3)=-grad_temp(3) + endif + endif + + if(flip<1)then + if(reflect>0)then + internal(2,3)=-int_temp(3) + if(flag==2)grad_int(2,3)=-grad_temp(3) + endif + endif + + ENDIF + + return +end subroutine perm_int3D + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! p e r m _ i n t 4 D +! ---------------------------------------------------------------------------------- +! Known +! +! *** Input *** +! int_temp <-- internal coordinates +! grad_temp <-- gradients +! exch <-- are the two fragments identical? 1=yes, 0=no +! flip1 <-- is fragment 1 symmetric upon 180 degree flip? 1=yes, 0=no +! flip2 <-- is fragment 2 symmetric upon 180 degree flip? 1=yes, 0=no +! natom1 <-- Number of atoms in the molecule +! natom1 <-- Number of atoms in the molecule +! flag <-- Type of calculation: 1=single point energies, 2= also gradients +! +! *** Output *** +! xinternal <-- internal coordinates for all symmetry partners +! xgrad_int <-- gradients ... +!*********************************************************************************** + +subroutine perm_int4D(int_temp,grad_temp,xinternal,xgrad_int,exch,flip1,flip2,natom1,natom2,flag,XMAG) + + implicit none + integer :: i,k2,k,exch,flip1,flip2,natom1,natom2,count,flag,XMAG + real*8 :: internal((exch+1)*(flip1+1)*(flip2+1),4),grad_int((exch+1)*(flip1+1)*(flip2+1),4) + real*8 :: xinternal((exch+1)*(flip1+1)*(flip2+1)*2,4) + real*8 :: xgrad_int((exch+1)*(flip1+1)*(flip2+1)*2,4) + real*8 :: int_temp(4),grad_temp(4),pii + + pii=dacos(-1d0) + + IF (XMAG==1) THEN + + do i=1,(exch+1)*(flip1+1)*(flip2+1) + internal(i,:)=int_temp(:) + if(flag==2)grad_int(i,:)=grad_temp(:) + enddo + + if(flip1>0)then + internal(2,2)=-int_temp(2) + internal(2,4)=pii-int_temp(4) + if(flag==2)grad_int(2,2)=-grad_temp(2) + if(flag==2)grad_int(2,4)=-grad_temp(4) + if(flip2>0)then + internal(3,3)=-int_temp(3) + internal(3,4)=pii-int_temp(4) + if(flag==2)grad_int(3,3)=-grad_temp(3) + if(flag==2)grad_int(3,4)=-grad_temp(4) + internal(4,2)=-int_temp(2) + internal(4,3)=-int_temp(3) + if(flag==2)grad_int(4,2)=-grad_temp(2) + if(flag==2)grad_int(4,3)=-grad_temp(3) + if(exch>0) then + internal(5,2)=-int_temp(3) + internal(5,3)=-int_temp(2) + if(flag==2)grad_int(5,2)=-grad_temp(3) + if(flag==2)grad_int(5,3)=-grad_temp(2) + internal(6,2)=-int_temp(3) + internal(6,3)=int_temp(2) + internal(6,4)=pii-int_temp(4) + if(flag==2)grad_int(6,2)=-grad_temp(3) + if(flag==2)grad_int(6,3)=grad_temp(2) + if(flag==2)grad_int(6,4)=-grad_temp(4) + internal(7,2)=int_temp(3) + internal(7,3)=-int_temp(2) + internal(7,4)=pii-int_temp(4) + if(flag==2)grad_int(7,2)=grad_temp(3) + if(flag==2)grad_int(7,3)=-grad_temp(2) + if(flag==2)grad_int(7,4)=-grad_temp(4) + internal(8,2)=int_temp(3) + internal(8,3)=int_temp(2) + if(flag==2)grad_int(8,2)=grad_temp(3) + if(flag==2)grad_int(8,3)=grad_temp(2) + endif + endif + endif + + if(flip1<1) then + if(flip2>0)then + internal(2,3)=-int_temp(3) + internal(2,4)=pii-int_temp(4) + if(flag==2)grad_int(2,3)=-grad_temp(3) + if(flag==2)grad_int(2,4)=-grad_temp(4) + endif + endif + + if(flip1<1) then + if(flip2<1) then + if(exch>0) then + internal(2,2)=-int_temp(3) + internal(2,3)=-int_temp(2) + if(flag==2)grad_int(2,2)=-grad_temp(3) + if(flag==2)grad_int(2,3)=-grad_temp(2) + endif + endif + endif + + ! Include all symmetry permutations: + count=0 + do k2=0,1! reflection to the other side of torsion + do k=1,(exch+1)*(flip1+1)*(flip2+1) + count=count+1 + xinternal(count,:)=internal(k,:) + xinternal(count,4)=internal(k,4)*(-1d0)**k2 + if(flag==2)then + xgrad_int(count,:)=grad_int(k,:) + xgrad_int(count,4)=grad_int(k,4)*(-1d0)**k2 + endif + enddo + enddo + + ENDIF + + + return +end subroutine perm_int4D + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! I N T _ C a r t +! ---------------------------------------------------------------------------------- +! Known the internal coordinates for a given configuration: internal2(X), +! the Cartesian coordinates for all atoms in the system are calculated. + +! *** Input *** Internal coordinates: +! internal2 <-- vector containing the internal coordinates + +! XSYS=1 --> two rigid molecules +! * XDIM=1 (Z - axis, two rigid molecules) +! internal2(1) -> R +! * XDIM=2, XBAS=0 (XZ - plane, molecule + atom) +! internal2(1) -> R +! internal2(2) -> cos(theta) +! * XDIM=2, XBAS=1 (theta-phi plane, molecule + atom, R is defined by parameter XXR) +! internal2(1) -> cos(theta) +! internal2(2) -> phi +! * XDIM=3 (molecule + atom) +! internal2(1) -> R +! internal2(2) -> cos(theta) +! internal2(3) -> phi +! * XDIM=4 (two rigid linear molecules) +! internal2(1) -> R +! internal2(2) -> cos(theta1) +! internal2(3) -> cos(theta2) +! internal2(4) -> phi +! +! ---------------------------------------------------------------------------------- + +subroutine INT_Cart(cartesians,internal2) + + use dynamic_parameters + implicit none + integer :: i + real*8 :: cartesians((natom1+natom2)*3),internal(XDIM),internal2(XDIM)!,internal4(6) + real*8 :: pii,sin_theta + + pii=dacos(-1d0) + internal=internal2 + + IF (XSYS==1) THEN! two rigid-fragments systems + if (XDIM==1) then + ! Cartesian coordinates for the atoms in the first fragment + if(natom1>1)call rm_cmass(ref1,mass(1:natom1),natom1,natom1) + cartesians(1:natom1*3)=ref1 + ! Cartesian coordinates for the atoms in the second fragment + if(natom2>1)call rm_cmass(ref2,mass(natom1+1:natom1+natom2),natom2,natom2) + cartesians(natom1*3+1:(natom1+natom2)*3)=ref2 + ! shift fragment 2 + do i=1,natom2 + cartesians((natom1+i)*3)=cartesians((natom1+i)*3)+internal(1) + enddo + elseif (XDIM==2) then + call INT_Cart_rigid2D(cartesians,internal,mass,natom1,natom2,ref1,ref2,XBAS,XXR) + elseif (XDIM==3) then + call INT_Cart_rigid3D(cartesians,internal,mass,natom1,natom2,ref1,ref2,nfold) + elseif (XDIM==4) then + call INT_Cart_rigid4D(cartesians,internal,mass,natom1,natom2,ref1,ref2) + endif + ENDIF + + return +end subroutine INT_Cart + + +! ---------------------------------------------------------------------------------- +! I N T _ C a r t _ r i g i d 2 D +! ---------------------------------------------------------------------------------- +! Known the internal coordinates (internal2) for a given configuration: +! * XBAS=0 (XZ - plane, molecule + atom) +! internal2(1) -> R +! internal2(2) -> cos(theta) +! * XBAS=1 (theta-phi plane, molecule + atom, R is defined by parameter XXR) +! internal2(1) -> cos(theta) +! internal2(2) -> phi +! ... the Cartesian coordinates for all atoms in the system (cart) are calculated + +! *** Input *** +! internal2 <-- vector containing internal coordinates +! mass <-- masses of all atoms +! natom1 <-- number of atoms in fragment 1 +! natom2 <-- number of atoms in fragment 2 +! ref1 <-- Cartesian coord. of atoms in frag. 1, placed along z-axis +! ref2 <-- Cartesian coord. of atoms in frag. 2, placed along z-axis + +subroutine INT_Cart_rigid2D(cart,internal2,mass,natom1,natom2,ref1,ref2,XBAS,XXR) + + implicit none + integer :: i,j,k,kp,lab,ierr,natom1,natom2,XBAS + real*8 :: internal(6),internal2(2),cart((natom1+natom2)*3),mass(natom1+natom2), & + ref1(natom1*3),ref1_temp(natom1*3),ref2(natom2*3),ref2_temp(natom2*3) + real*8 :: cart_mat1(3,natom1),cart_mat(3,natom1+natom2),cart_ref1(3,natom1),cm(3),& + cart_ref2(3,natom2),cart_ref1t(3,natom1),cart_ref2t(3,natom2),U_rot(3,3) + real*8 :: cart_mat2(3,natom2),cart_frag2(natom2*3),quat(4),quat2(4),pii,vec1(3) + real*8 :: gamma1,gamma2,beta1,beta2,alpha1,alpha2,vec2(3),sin_theta,XXR + +! if (XBAS==0) then +! ! Cartesian coordinates for the atoms in the first fragment +! cartesians(1:natom1*3)=ref1 +! ! Cartesian coordinates for the extra atom +! sin_theta=dsqrt(1.d0-internal(2)**2) +! cartesians(natom1*3+1)=internal(1)*sin_theta +! cartesians(natom1*3+2)=0.d0 +! cartesians(natom1*3+3)=internal(1)*internal(2) +! elseif (XBAS==1) then +! ! Cartesian coordinates for the atoms in the first fragment +! cartesians(1:natom1*3)=ref1 +! ! Cartesian coordinates for the extra atom +! sin_theta=dsqrt(1.d0-internal(1)**2) +! cartesians(natom1*3+1)=XXR*sin_theta*dcos(internal(2)) +! cartesians(natom1*3+2)=XXR*sin_theta*dsin(internal(2)) +! cartesians(natom1*3+3)=XXR*internal(1) +! endif + + pii=acos(-1d0) + + ref1_temp=ref1 + ref2_temp=ref2 + + ! set c.m. of fragment 1 at origin + call rm_cmass(ref1_temp,mass(1:natom1),natom1,natom1) + ! Cartesian coordinates for the atoms in fragment 1 + do i=1,3*natom1 + cart(i)=ref1_temp(i) + enddo + + ! set c.m. of fragment 2 at origin +! ref2_temp=0d0 + if(natom2>1)call rm_cmass(ref2_temp,mass(natom1+1:natom1+natom2),natom2,natom2) + ! Cartesian coordinates of c.m. for fragment 2 + if (XBAS==0) then + sin_theta=dsqrt(1.d0-internal2(2)**2) + cm(1)=internal2(1)*sin_theta + cm(2)=0.d0 + cm(3)=internal2(1)*internal2(2) + elseif (XBAS==1) then + sin_theta=dsqrt(1.d0-internal2(1)**2) + cm(1)=XXR*sin_theta*dcos(internal2(2)) + cm(2)=XXR*sin_theta*dsin(internal2(2)) + cm(3)=XXR*internal2(1) + endif + ! shift fragment 2 + do k=1,natom2 + do kp=1,3 + ref2_temp((k-1)*3+kp)=ref2_temp((k-1)*3+kp)+cm(kp) + enddo + enddo + ! Cartesian coordinates for the atoms in fragment 2 + do i=1,3*natom2 + cart(3*natom1+i)=ref2_temp(i) + enddo + + return +end subroutine INT_Cart_rigid2D + + +! ---------------------------------------------------------------------------------- +! I N T _ C a r t _ r i g i d 3 D +! ---------------------------------------------------------------------------------- +! Known the internal coordinates (internal2) for a given configuration: +! internal2(1) -> R +! internal2(2) -> cos(theta1) +! internal2(3) -> phi +! the Cartesian coordinates for all atoms in the system (cart) are calculated + +! *** Input *** +! internal2 <-- vector containing internal coordinates +! mass <-- masses of all atoms +! natom1 <-- number of atoms in fragment 1 +! natom2 <-- number of atoms in fragment 2 +! ref1 <-- Cartesian coord. of atoms in frag. 1, placed along z-axis +! ref2 <-- Cartesian coord. of atoms in frag. 2, placed along z-axis + +subroutine INT_Cart_rigid3D(cart,internal2,mass,natom1,natom2,ref1,ref2,nfold) + + implicit none + integer :: i,j,k,kp,lab,ierr,natom1,natom2,nfold + real*8 :: internal(6),internal2(3),cart((natom1+natom2)*3),mass(natom1+natom2), & + ref1(natom1*3),ref1_temp(natom1*3),ref2(natom2*3),ref2_temp(natom2*3) + real*8 :: cart_mat1(3,natom1),cart_mat(3,natom1+natom2),cart_ref1(3,natom1),cm(3),& + cart_ref2(3,natom2),cart_ref1t(3,natom1),cart_ref2t(3,natom2),U_rot(3,3) + real*8 :: cart_mat2(3,natom2),cart_frag2(natom2*3),pii + real*8 :: gamma1,gamma2,beta1,beta2,alpha1,alpha2,sin_theta + +! ! Cartesian coordinates for the atoms in the molecule +! cartesians(1:natom1*3)=ref1 +! ! Cartesian coordinates for the extra atom +! sin_theta=dsqrt(1.d0-internal(2)**2) +! cartesians(natom1*3+1)=internal(1)*sin_theta*dcos(internal(3)/nfold)! use a reduced phi-range if.. +! cartesians(natom1*3+2)=internal(1)*sin_theta*dsin(internal(3)/nfold)! ..n-fold (rot. symm.) exist +! cartesians(natom1*3+3)=internal(1)*internal(2) + + pii=acos(-1d0) + + ref1_temp=ref1 + ref2_temp=ref2 + + ! set c.m. of fragment 1 at origin + call rm_cmass(ref1_temp,mass(1:natom1),natom1,natom1) ! check!! + ! Cartesian coordinates for the atoms in fragment 1 + do i=1,3*natom1 + cart(i)=ref1_temp(i) + enddo + !cart(1:natom1*3)=ref1_temp + + ! set c.m. of fragment 2 at origin + !ref2_temp=0d0 + if(natom2>1)call rm_cmass(ref2_temp,mass(natom1+1:natom1+natom2),natom2,natom2) + ! Cartesian coordinates of c.m. for fragment 2 + sin_theta=dsqrt(1.d0-internal2(2)**2) + cm(1)=internal2(1)*sin_theta*dcos(internal2(3)/nfold)! use a reduced phi-range if --> + cm(2)=internal2(1)*sin_theta*dsin(internal2(3)/nfold)! --> n-fold (rotational symm.) exist + cm(3)=internal2(1)*internal2(2) + ! shift fragment 2 + do k=1,natom2 + do kp=1,3 + ref2_temp((k-1)*3+kp)=ref2_temp((k-1)*3+kp)+cm(kp) + enddo + enddo + ! Cartesian coordinates for the atoms in fragment 2 + do i=1,3*natom2 + cart(3*natom1+i)=ref2_temp(i) + enddo + + return +end subroutine INT_Cart_rigid3D + +! ---------------------------------------------------------------------------------- +! I N T _ C a r t _ r i g i d 4 D +! ---------------------------------------------------------------------------------- +! Known the internal coordinates (internal2) for a given configuration: +! internal2(1) -> R +! internal2(2) -> cos(theta1) +! internal2(3) -> cos(theta2) +! internal2(4) -> phi +! the Cartesian coordinates for all atoms in the system (cart) are calculated + +! *** Input *** +! internal2 <-- vector containing internal coordinates +! mass <-- masses of all atoms +! natom1 <-- number of atoms in fragment 1 +! natom2 <-- number of atoms in fragment 2 +! ref1 <-- Cartesian coord. of atoms in frag. 1, placed along z-axis +! ref2 <-- Cartesian coord. of atoms in frag. 2, placed along z-axis + +subroutine INT_Cart_rigid4D(cart,internal2,mass,natom1,natom2,ref1,ref2) + + implicit none + integer :: i,j,k,kp,lab,ierr,natom1,natom2 + real*8 :: internal(6),internal2(4),cart((natom1+natom2)*3),mass(natom1+natom2), & + ref1(natom1*3),ref1_temp(natom1*3),ref2(natom2*3),ref2_temp(natom2*3) + real*8 :: cart_mat1(3,natom1),cart_mat(3,natom1+natom2),cart_ref1(3,natom1),cm(3),& + cart_ref2(3,natom2),cart_ref1t(3,natom1),cart_ref2t(3,natom2),U_rot(3,3) + real*8 :: cart_mat2(3,natom2),cart_frag2(natom2*3),quat(4),quat2(4),pii,vec1(3) + real*8 :: gamma1,gamma2,beta1,beta2,alpha1,alpha2,vec2(3) + + pii=acos(-1d0) + + internal(1)=internal2(1) + internal(2)=0d0 + internal(3)=internal2(2) + internal(4)=0d0 + internal(5)=internal2(3) + internal(6)=internal2(4) + ref1_temp=ref1 + ref2_temp=ref2 + + ! set c.m. of fragment 1 at origin + call rm_cmass(ref1_temp,mass(1:natom1),natom1,natom1) + ! set c.m. of fragment 2 at origin + call rm_cmass(ref2_temp,mass(natom1+1:natom1+natom2),natom2,natom2) + + ! Cartesian coordinates of c.m. for fragment 2 + cm(1)=0d0 + cm(2)=0d0 + cm(3)=internal(1) + + alpha1=0d0 + gamma1=internal(2) + beta1=dacos(internal(3)) + + ! U = Z1(alpha1) Y2(beta1) Z3(gamma1) + !ZYZ for proper Euler angles + U_rot(1,1)=dcos(alpha1)*dcos(beta1)*dcos(gamma1)-dsin(alpha1)*dsin(gamma1) + U_rot(1,2)=-dcos(alpha1)*dcos(beta1)*dsin(gamma1)-dsin(alpha1)*dcos(gamma1) + U_rot(1,3)=dcos(alpha1)*dsin(beta1) + + U_rot(2,1)=dsin(alpha1)*dcos(beta1)*dcos(gamma1)+dcos(alpha1)*dsin(gamma1) + U_rot(2,2)=-dsin(alpha1)*dcos(beta1)*dsin(gamma1)+dcos(alpha1)*dcos(gamma1) + U_rot(2,3)=dsin(alpha1)*dsin(beta1) + + U_rot(3,1)=-dsin(beta1)*dcos(gamma1) + U_rot(3,2)=dsin(beta1)*dsin(gamma1) + U_rot(3,3)=dcos(beta1) + + call vec_to_mat2(ref1_temp,cart_ref1,natom1) + call rotmol(natom1,cart_ref1,cart_ref1t,U_rot) + call mat_to_vec2(cart_ref1t,ref1_temp,natom1) + + gamma2=internal(4) + beta2=dacos(internal(5)) + alpha2=-internal(6) + + U_rot(1,1)=dcos(alpha2)*dcos(beta2)*dcos(gamma2)-dsin(alpha2)*dsin(gamma2) + U_rot(1,2)=-dcos(alpha2)*dcos(beta2)*dsin(gamma2)-dsin(alpha2)*dcos(gamma2) + U_rot(1,3)=dcos(alpha2)*dsin(beta2) + + U_rot(2,1)=dsin(alpha2)*dcos(beta2)*dcos(gamma2)+dcos(alpha2)*dsin(gamma2) + U_rot(2,2)=-dsin(alpha2)*dcos(beta2)*dsin(gamma2)+dcos(alpha2)*dcos(gamma2) + U_rot(2,3)=dsin(alpha2)*dsin(beta2) + + U_rot(3,1)=-dsin(beta2)*dcos(gamma2) + U_rot(3,2)=dsin(beta2)*dsin(gamma2) + U_rot(3,3)=dcos(beta2) + + call vec_to_mat2(ref2_temp,cart_ref2,natom2) + call rotmol(natom2,cart_ref2,cart_ref2t,U_rot) + call mat_to_vec2(cart_ref2t,ref2_temp,natom2) + + do k=1,natom2 + do kp=1,3 + ref2_temp((k-1)*3+kp)=ref2_temp((k-1)*3+kp)+cm(kp) + enddo + enddo + + do i=1,3*natom2 + cart(3*natom1+i)=ref2_temp(i) + enddo + + do i=1,3*natom1 + cart(i)=ref1_temp(i) + enddo + + return +end subroutine INT_Cart_rigid4D + +!******************************* A U T O S U R F *********************************! +!===================================================================================! +!-----------------------------------------------------------------------------------! +!- -! +!- AUTOSURF Package: A set of programs for the automated construction -! +!- of Potential Energy Surfaces on van der Waals systems -! +!- -! +!-----------------------------------------------------------------------------------! +!===================================================================================! +!***********************************************************************************! +!- Set of Fortran90 functions for "AUTOSURF-PES" PROGRAM -! +!***********************************************************************************! + + +! F U N C T I O N S + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! F U N C (xi) +! ---------------------------------------------------------------------------------- +! Returns the negative-squared-difference (surface) between two consecutive fits + +! *** Input *** +! xi <-- vector containing the internal coordinates + +function func(xi) + +use nrtype +USE dynamic_parameters +implicit none +!----------------------------------------------------------------------------------- +! Interface blocks +INTERFACE! Energy of minimal basis and high-level ab initio + FUNCTION func_actual_min(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_min + END FUNCTION func_actual_min +end interface +INTERFACE! Energy of minimal basis and low-level ab initio + FUNCTION func_actual_seed(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_seed + END FUNCTION func_actual_seed +end interface +INTERFACE! Energy of largest basis and high-level ab initio + FUNCTION func_actual(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual + END FUNCTION func_actual +end interface +INTERFACE! Energy of secondary basis and high-level ab initio + FUNCTION func_actual_lower(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_lower + END FUNCTION func_actual_lower +end interface +!----------------------------------------------------------------------------------- + +REAL*8, DIMENSION(:), INTENT(IN) :: xi +REAL*8 :: func,temp,temp1 +integer :: j,count + +!*** MAKE [func(xi)=0] IF: + +!... the geometry is outside the symm. subspace +do j=1,XDIM + if(xi(j)>rmax(j).or.xi(j)0) then + temp=func_actual_seed(xi) + if(temp>Max_E_seed)then + func=0d0 + return + endif +endif +temp1=func_actual_min(xi) +if(subzero==0)then + if(temp1>Max_E)then + func=0d0 + return + endif +else + if(temp1+temp>Max_E)then + func=0d0 + return + endif +endif + +func=-1.0d0*(func_actual(xi)-func_actual_lower(xi))**2 + +return +end function func + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! F U N C 1 (xi) +! ---------------------------------------------------------------------------------- +! Returns the negative-squared-difference (surface) between two consecutive fits. +! Ibidem. "FUNC(xi)" but modified to be used in all the configuration space instead, +! and not only in the symmetry-region where new geometries are located. +! If no symmetry exist for the system: "func1" = "func". + +! *** Input *** +! xi <-- vector containing the internal coordinates + +function func1(xi) + +use nrtype +USE dynamic_parameters +implicit none +!----------------------------------------------------------------------------------- +! Interface blocks +INTERFACE + FUNCTION func_actual_min(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_min + END FUNCTION func_actual_min +end interface +INTERFACE + FUNCTION func_actual_seed(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_seed + END FUNCTION func_actual_seed +end interface +INTERFACE! Energy of largest basis and high-level ab initio + FUNCTION func_actual(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual + END FUNCTION func_actual +end interface +INTERFACE! Energy of secondary basis and high-level ab initio + FUNCTION func_actual_lower(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_lower + END FUNCTION func_actual_lower +end interface +!----------------------------------------------------------------------------------- + +REAL*8, DIMENSION(:), INTENT(IN) :: xi +REAL*8 :: func1,temp,temp1 +integer :: j,count + +!*** MAKE [func1(xi)=0] IF: + +!... the geometry is outside the allowed configuration space +do j=1,XDIM + if(xi(j)>rmaxNS(j).or.xi(j)0) then + temp=func_actual_seed(xi) + if(temp>Max_E_seed)then + func1=0d0 + return + endif +endif +temp1=func_actual_min(xi) +if(subzero==0)then + if(temp1>Max_E)then + func1=0d0 + return + endif +else + if(temp1+temp>Max_E)then + func1=0d0 + return + endif +endif + +func1=-1.0d0*(func_actual(xi)-func_actual_lower(xi))**2 + +return +end function func1 + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! D F U N C _ A C T U A L _ A N A L 1 (xi) +! ---------------------------------------------------------------------------------- +! Returns energy & analytic gradient for the largest basis and high-level ab initio + +! *** Input *** +! xi <-- vector containing the internal coordinates + +function dfunc_actual_anal1(xi) + + use dynamic_parameters + implicit none + + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: dfunc_actual_anal1(XDIM+1), temp(XDIM+1) + + call derivpoten_rigidXD(temp,xi,order,order0,count3,coords,d,b2,symparts,maxpoints,alpha,xbeta, & + epss,zz,basis_1,W_a,XDIM,XBAS,XDIST) + dfunc_actual_anal1=temp + + return +end function dfunc_actual_anal1 + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! D F U N C _ A C T U A L _ A N A L 2 (xi) +! ---------------------------------------------------------------------------------- +! Returns energy & analytic gradient for the secondary basis and high-level ab initio + +! *** Input *** +! xi <-- vector containing the internal coordinates + +function dfunc_actual_anal2(xi) + + use dynamic_parameters + implicit none + + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: dfunc_actual_anal2(XDIM+1),temp(XDIM+1) + + call derivpoten_rigidXD(temp,xi,order-1,order0,count3,coords,d,b2_lower,symparts, & + maxpoints,alpha,xbeta,epss,zz,basis_2,W_a,XDIM,XBAS,XDIST) + dfunc_actual_anal2=temp + + return +end function dfunc_actual_anal2 + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! D F U N C _ A C T U A L _ A N A L 3 (xi) +! ---------------------------------------------------------------------------------- +! Returns energy & analytic gradient for the secondary basis and high-level ab initio, +! with different number of terms in the expansion: Debug purposes... + +! *** Input *** +! xi <-- vector containing the internal coordinates + +function dfunc_actual_anal3(xi) + + use dynamic_parameters + implicit none + + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: dfunc_actual_anal3(XDIM+1),temp(XDIM+1) + + order_temp=order + order_temp(2)=5 + order_temp(3)=5 + call derivpoten_rigidXD(temp,xi,order_temp,order_temp0,count3,coords,d,b2_lower,symparts, & + maxpoints,alpha,xbeta,epss,zz,basis_2,W_a,XDIM,XBAS,XDIST) + dfunc_actual_anal3=temp + + return +end function dfunc_actual_anal3 + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! D F U N C _ A C T U A L _ S E E D (xi) +! ---------------------------------------------------------------------------------- +! Returns energy & analytic gradient for the low-level ab initio + +! *** Input *** +! xi <-- vector containing the internal coordinates + +function dfunc_actual_seed(xi) + + use dynamic_parameters + implicit none + + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: dfunc_actual_seed(XDIM+1),temp(XDIM+1) + + call derivpoten_rigidXD(temp,xi,order_low,order_low0,count_seed,coords_seed,d_seed,b2_seed, & + symparts,maxpoints,alpha,xbeta,epss,zz_low,basis_4,W_a,XDIM,XBAS,XDIST) + dfunc_actual_seed=temp + + return +end function dfunc_actual_seed + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! D F U N C _ A C T U A L _ M I N (xi) +! ---------------------------------------------------------------------------------- +! Returns energy & analytic gradient for the minimal basis and high-level ab initio + +! *** Input *** +! xi <-- vector containing the internal coordinates + +function dfunc_actual_min(xi) + + use dynamic_parameters + implicit none + + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: dfunc_actual_min(XDIM+1),temp(XDIM+1) + + call derivpoten_rigidXD(temp,xi,order_min,order0,count3,coords,d,b2_minimal,symparts,maxpoints, & + alpha,xbeta,epss,zz,basis_3,W_a,XDIM,XBAS,XDIST) + dfunc_actual_min=temp + + return +end function dfunc_actual_min + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! D F U N C (xi) +! ---------------------------------------------------------------------------------- +! Returns analytic gradient for the (negative) squared difference-surface ('func'). +! 'func' and 'dfunc' must be what is used by canned CJ-minimization code... + +! *** Input *** +! xi <-- vector containing the internal coordinates + +function dfunc(xi) + +use nrtype +USE dynamic_parameters +implicit none + +INTERFACE + function dfunc_actual_anal1(xi) + use nrtype + USE dynamic_parameters + implicit none + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8, DIMENSION(size(xi)) :: x2,x3 + REAL*8, DIMENSION(size(xi)+1) :: dfunc_actual_anal1 + end function dfunc_actual_anal1 +end interface +INTERFACE + function dfunc_actual_anal2(xi) + use nrtype + USE dynamic_parameters + implicit none + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8, DIMENSION(size(xi)) :: x2,x3 + REAL*8, DIMENSION(size(xi)+1) :: dfunc_actual_anal2 + end function dfunc_actual_anal2 +end interface +INTERFACE + FUNCTION func_actual_min(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_min + END FUNCTION func_actual_min +end interface +INTERFACE + FUNCTION func_actual_seed(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_seed + END FUNCTION func_actual_seed +end interface + +REAL*8, DIMENSION(:), INTENT(IN) :: xi +REAL*8, DIMENSION(size(xi)) :: dfunc,x2,x3 +integer :: i,j,k +real*8 :: temp(XDIM+1),grad1(XDIM),grad2(XDIM),jac3(XDIM) +real*8 :: val1,val2,tampon,tampon1,h2wn,dist,pii + +pii=acos(-1d0) + + +!*** MAKE [dfunc(xi)=0] IF: + +!... the geometry is outside the symm. subspace +do j=1,XDIM + if(xi(j)>rmax(j).or.xi(j)0) then + tampon=func_actual_seed(xi) + if(tampon>Max_E_seed)then + dfunc=0d0 + return + endif +endif +tampon1=func_actual_min(xi) +if(subzero==0)then + if(tampon1>Max_E)then + dfunc=0d0 + return + endif +endif +if(subzero==1)then + if(tampon1+tampon>Max_E)then + dfunc=0d0 + return + endif +endif + +temp=dfunc_actual_anal1(xi) +val1=temp(1) +grad1(:)=temp(2:XDIM+1) + +temp=dfunc_actual_anal2(xi) +val2=temp(1) +grad2(:)=temp(2:XDIM+1) + +dfunc(:)=-2d0*(val1-val2)*(grad1(:)-grad2(:)) +!write(570+myid,*) xi +!write(570+myid,*) dfunc + +return +end function dfunc + + +! actual: call poten_rigidXD(temp,xi, order, count3, coords, d, b2, symparts,maxpoints,alpha,xbeta,epss, zz, basis_1, XDIM,XBAS) +! lower: call poten_rigidXD(temp,xi, order-1, count3, coords, d, b2_lower, symparts,maxpoints,alpha,xbeta,epss, zz, basis_2, XDIM,XBAS) +! minimal: call poten_rigidXD(temp,xi, order_min, count3, coords, d, b2_minimal, symparts,maxpoints,alpha,xbeta,epss, zz, basis_3, XDIM,XBAS) +! LOW-GRID: call poten_rigidXD(temp,xi, order_low, count_seed, coords_seed, d_seed, b2_seed, symparts,maxpoints,alpha,xbeta,epss, zz_low, basis_4, XDIM,XBAS) + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! f u n c _ a c t u a l (xi) +! ---------------------------------------------------------------------------------- +! Returns energy for the largest basis-set and high-level ab initio + +! *** Input *** +! xi <-- vector containing the internal coordinates + +function func_actual(xi) + + use dynamic_parameters + implicit none + + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual,temp + + ! DEBUG... + !write(6,*)xi,order,count3,alpha,xbeta,epss,zz,basis_1,XDIM,XBAS,symparts,maxpoints + !pause + !write(6,*)d(1:count3) + !pause + !write(6,*)coords(1:count3,:) + !pause + !write(6,*)b2(:,1:count3) + !stop + + call poten_rigidXD(temp,xi,order,order0,count3,coords,d,b2,symparts,maxpoints,alpha,xbeta,epss, & + zz,basis_1,XDIM,XBAS) + func_actual=temp + + return +end function func_actual + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! f u n c _ a c t u a l _ l o w e r (xi) +! ---------------------------------------------------------------------------------- +! Returns energy for the lower basis-set (order_i-1) and high-level ab initio + +! *** Input *** +! xi <-- vector containing the internal coordinates + +function func_actual_lower(xi) + + use dynamic_parameters + implicit none + + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_lower,temp + + call poten_rigidXD(temp,xi,order-1,order0,count3,coords,d,b2_lower,symparts,maxpoints,alpha, & + xbeta,epss,zz,basis_2,XDIM,XBAS) + func_actual_lower=temp + + return +end function func_actual_lower + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! f u n c _ a c t u a l _ m i n (xi) +! ---------------------------------------------------------------------------------- +! Returns energy for the minimal basis-set and high-level ab initio + +! *** Input *** +! xi <-- vector containing the internal coordinates + +function func_actual_min(xi) + + use dynamic_parameters + implicit none + + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_min,temp + + call poten_rigidXD(temp,xi,order_min,order0,count3,coords,d,b2_minimal,symparts,maxpoints, & + alpha,xbeta,epss,zz,basis_3,XDIM,XBAS) + func_actual_min=temp + + return +end function func_actual_min + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! f u n c _ a c t u a l _ s e e d (xi) +! ---------------------------------------------------------------------------------- +! Returns energy for the low-level ab initio + +! *** Input *** +! xi <-- vector containing the internal coordinates + +function func_actual_seed(xi) + + use dynamic_parameters + implicit none + + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_seed,temp + + call poten_rigidXD(temp,xi,order_low,order_low0,count_seed,coords_seed,d_seed,b2_seed, & + symparts,maxpoints,alpha,xbeta,epss,zz_low,basis_4,XDIM,XBAS) + func_actual_seed=temp + + return +end function func_actual_seed + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! D B R E N T (ax,bx,cx,func,dfunc,tol,xmin) +! ---------------------------------------------------------------------------------- +! +! *** Input *** +! <-- + +FUNCTION dbrent(ax,bx,cx,func,dfunc,tol,xmin) + +USE nrtype; USE nrutil, ONLY : nrerror +IMPLICIT NONE +REAL(SP), INTENT(IN) :: ax,bx,cx,tol +REAL(SP), INTENT(OUT) :: xmin +REAL(SP) :: dbrent +INTERFACE + FUNCTION func(x) + USE nrtype + IMPLICIT NONE + REAL*8, INTENT(IN) :: x + REAL*8 :: func + END FUNCTION func +!BL + FUNCTION dfunc(x) + USE nrtype + IMPLICIT NONE + REAL*8, INTENT(IN) :: x + REAL*8 :: dfunc + END FUNCTION dfunc +END INTERFACE + +INTEGER(I4B), PARAMETER :: ITMAX=100 +REAL(SP), PARAMETER :: ZEPS=1.0e-3_sp*epsilon(ax) +INTEGER(I4B) :: iter +REAL(SP) :: a,b,d,d1,d2,du,dv,dw,dx,e,fu,fv,fw,fx,olde,tol1,tol2,& + u,u1,u2,v,w,x,xm +LOGICAL :: ok1,ok2 +a=min(ax,cx) +b=max(ax,cx) +v=bx +w=v +x=v +e=0.0 +fx=func(x) +fv=fx +fw=fx +dx=dfunc(x) +dv=dx +dw=dx +do iter=1,ITMAX + xm=0.5_sp*(a+b) + tol1=tol*abs(x)+ZEPS + tol2=2.0_sp*tol1 + if (abs(x-xm) <= (tol2-0.5_sp*(b-a))) exit + if (abs(e) > tol1) then + d1=2.0_sp*(b-a) + d2=d1 + if (dw /= dx) d1=(w-x)*dx/(dx-dw) + if (dv /= dx) d2=(v-x)*dx/(dx-dv) + u1=x+d1 + u2=x+d2 + ok1=((a-u1)*(u1-b) > 0.0) .and. (dx*d1 <= 0.0) + ok2=((a-u2)*(u2-b) > 0.0) .and. (dx*d2 <= 0.0) + olde=e + e=d + if (ok1 .or. ok2) then + if (ok1 .and. ok2) then + d=merge(d1,d2, abs(d1) < abs(d2)) + else + d=merge(d1,d2,ok1) + end if + if (abs(d) <= abs(0.5_sp*olde)) then + u=x+d + if (u-a < tol2 .or. b-u < tol2) & + d=sign(tol1,xm-x) + else + e=merge(a,b, dx >= 0.0)-x + d=0.5_sp*e + end if + else + e=merge(a,b, dx >= 0.0)-x + d=0.5_sp*e + end if + else + e=merge(a,b, dx >= 0.0)-x + d=0.5_sp*e + end if + if (abs(d) >= tol1) then + u=x+d + fu=func(u) + else + u=x+sign(tol1,d) + fu=func(u) + if (fu > fx) exit + end if + du=dfunc(u) + if (fu <= fx) then + if (u >= x) then + a=x + else + b=x + end if + call mov3(v,fv,dv,w,fw,dw) + call mov3(w,fw,dw,x,fx,dx) + call mov3(x,fx,dx,u,fu,du) + else + if (u < x) then + a=u + else + b=u + end if + if (fu <= fw .or. w == x) then + call mov3(v,fv,dv,w,fw,dw) + call mov3(w,fw,dw,u,fu,du) + else if (fu <= fv .or. v == x .or. v == w) then + call mov3(v,fv,dv,u,fu,du) + end if + end if +end do +if (iter > ITMAX) call nrerror('dbrent: exceeded maximum iterations') +xmin=x +dbrent=fx +CONTAINS +!BL +SUBROUTINE mov3(a,b,c,d,e,f) +REAL(SP), INTENT(IN) :: d,e,f +REAL(SP), INTENT(OUT) :: a,b,c +a=d +b=e +c=f +END SUBROUTINE mov3 +END FUNCTION dbrent + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! p o t e n _ b a s i s _ r i g i d 4 D (xi) +! ---------------------------------------------------------------------------------- +! + +! *** Input *** +! xi <-- vector containing the internal coordinates +! count3 <-- number of ab initio points included in the fit (including symm. partners) +! order <-- +! order(1) <-- maximum power of R = exp(alpha*r) +! order(2) <-- maximum value of L1 +! order(3) <-- maximum value of L2 +! order(4) <-- maximum value of L = L1 + L2 + +! actual: call poten_basis_rigid4D(somme,order, count3,coords,b, symparts,maxpoints,alpha,xbeta,ind,ind2,support,pot,ab_flag,norm) +! lower: call poten_basis_rigid4D(somme,order-1, count3,coords,b_lower, symparts,maxpoints,alpha,xbeta,ind,ind2,support,pot,ab_flag,norm) + +subroutine poten_basis_rigid2D(somme,order,order0,count3,coords,BBB,symparts,maxpoints,alpha, & + xbeta,ind,ind2,support,pot,ab_flag,norm) + + use nrtype + implicit none + INTEGER, PARAMETER :: XDIM = 2 + INTEGER, INTENT(IN) :: count3,symparts,maxpoints,support,ab_flag,ind2(count3) + INTEGER, INTENT(IN) :: order(XDIM),order0(XDIM) + REAL*8, INTENT(IN) :: coords(symparts*maxpoints,XDIM),BBB((XDIM*(ab_flag-1)+1)*support) + REAL*8, INTENT(IN) :: alpha,xbeta,ind(count3),pot(symparts*maxpoints) + REAL*8, INTENT(OUT) :: somme,norm + + integer :: i,j,l1,l2,l3,l4,l,jj,R,M + integer :: count + real*8 :: temp,weight,jac4(XDIM) + real*8,allocatable :: PM1(:,:),PD1(:,:) + + allocate(PM1(0:order(2)+1,0:order(2)+1),PD1(0:order(2)+1,0:order(2)+1)) + + somme=0d0 + norm=0d0 + do i=2,support + temp=0d0 + jj=ind2(count3+1-i) + Jac4=coords(jj,:) + jac4(1)=exp(alpha*jac4(1)**xbeta) + call LPMN(order(2)+1,order(2),order(2),jac4(2),PM1,PD1) + weight=ind(jj) + norm=norm+weight**2 + temp=temp+BBB(1) + !if (i==2) write(6,*)'0',somme,weight,temp,pot(jj),norm,BBB(1),Jac4 + count=1 + do R=1,order(1) + do L1=0,order(2) + count=count+1 + temp=temp+BBB(count)*(jac4(1))**(R)*PM1(M,L1) + enddo + enddo + somme=somme+(weight*(temp-pot(jj)))**2 + enddo + + return +end subroutine poten_basis_rigid2D + + +subroutine poten_basis_rigid3D(somme,order,order0,count3,coords,BBB,symparts,maxpoints, & + alpha,xbeta,ind,ind2,support,pot,ab_flag,norm) + + use nrtype + implicit none + INTEGER, PARAMETER :: XDIM = 3 + INTEGER, INTENT(IN) :: count3,symparts,maxpoints,support,ab_flag,ind2(count3) + INTEGER, INTENT(IN) :: order(XDIM),order0(XDIM) + REAL*8, INTENT(IN) :: coords(symparts*maxpoints,XDIM),BBB((XDIM*(ab_flag-1)+1)*support) + REAL*8, INTENT(IN) :: alpha,xbeta,ind(count3),pot(symparts*maxpoints) + REAL*8, INTENT(OUT) :: somme,norm + + integer :: i,j,l1,l2,l3,l4,l,jj,R,M + integer :: count + real*8 :: temp,weight,jac4(XDIM) + real*8,allocatable :: PM1(:,:),PD1(:,:) + + allocate(PM1(0:order(2)+1,0:order(2)+1),PD1(0:order(2)+1,0:order(2)+1)) + + somme=0d0 + norm=0d0 + do i=2,support + temp=0d0 + jj=ind2(count3+1-i) + Jac4=coords(jj,:) + jac4(1)=exp(alpha*jac4(1)**xbeta) + call LPMN(order(2)+1,order(2),order(2),jac4(2),PM1,PD1) + weight=ind(jj) + norm=norm+weight**2 + temp=temp+BBB(1) + !if (i==2) write(6,*)'0',somme,weight,temp,pot(jj),norm,BBB(1),Jac4 + count=1 + do R=order0(1),order(1) + IF (order0(1)==0) THEN + do L1=order0(2),3 + do M=order0(3),min(L1,2) + if((L1+M)==0)cycle + count=count+1 + temp=temp+BBB(count)*PM1(M,L1)*dcos(dble(M)*jac4(3)) + enddo + enddo + ELSE + do L1=order0(2),order(2) + do M=order0(3),min(L1,order(3)) + count=count+1 + temp=temp+BBB(count)*(jac4(1))**(R)*PM1(M,L1)*dcos(dble(M)*jac4(3)) + enddo + enddo + ENDIF + enddo + somme=somme+(weight*(temp-pot(jj)))**2 + enddo + + return +end subroutine poten_basis_rigid3D + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! m a k e _ m a t r i x B B +! ---------------------------------------------------------------------------------- +! + +! *** Input *** + + + + +subroutine make_matrixBB_rigid2D(BB,order,order0,support,alpha,xbeta,ind,ind2,count3,coords, & + symparts,maxpoints,ab_flag,basis) + + use nrtype + implicit none + + INTEGER, PARAMETER :: XDIM = 2 + INTEGER, INTENT(IN) :: count3,support,symparts,maxpoints,ab_flag,basis + INTEGER, INTENT(IN) :: order(XDIM),order0(XDIM),ind2(count3) + REAL*8, INTENT(IN) :: ind(count3),coords(symparts*maxpoints,XDIM),alpha,xbeta + REAL*8, INTENT(OUT) :: BB((XDIM*(ab_flag-1)+1)*support,basis) + + integer :: count + integer :: R,M,l1,l2,jj,i2 + real*8,allocatable :: PM1(:,:),PD1(:,:) + real*8 :: jac4(XDIM),weight + + allocate(PM1(0:order(1)+1,0:order(1)+1),PD1(0:order(1)+1,0:order(1)+1)) + + BB=0d0 + do i2=1,support + jj=ind2(count3+1-i2) + Jac4=coords(jj,:) + jac4(1)=exp(alpha*jac4(1)**xbeta) + call LPMN(order(1)+1,order(1),order(1),jac4(2),PM1,PD1) + weight=ind(jj) + BB(i2,1)=weight + count=1 + do R=1,order(1) + do L1=0,order(1) + count=count+1 + BB(i2,count)=weight*(jac4(1))**(R)*PM1(M,L1) + if (ab_flag==2) then + BB(i2+support,count)=weight*dble(R)*alpha*xbeta*(jac4(1))**(xbeta-1d0)*(jac4(1))**(R)*PM1(M,L1) + BB(i2+2*support,count)=weight*(jac4(1))**(R)*PD1(M,L1) + endif + enddo + enddo + enddo + + return +end subroutine make_matrixBB_rigid2D + + +subroutine make_matrixBB_rigid3D(BB,order,order0,support,alpha,xbeta,ind,ind2,count3,coords, & + symparts,maxpoints,ab_flag,basis) + + use nrtype + implicit none + INTEGER, PARAMETER :: XDIM = 3 + INTEGER, INTENT(IN) :: count3,support,symparts,maxpoints,ab_flag,basis + INTEGER, INTENT(IN) :: order(XDIM),order0(XDIM),ind2(count3) + REAL*8, INTENT(IN) :: ind(count3),coords(symparts*maxpoints,XDIM),alpha,xbeta + REAL*8, INTENT(OUT) :: BB((XDIM*(ab_flag-1)+1)*support,basis) + integer :: count + integer :: R,M,l1,l2,jj,i2 + real*8,allocatable :: PM1(:,:),PD1(:,:) + real*8 :: jac4(XDIM),weight + + allocate(PM1(0:order(2)+1,0:order(2)+1),PD1(0:order(2)+1,0:order(2)+1)) + + BB=0d0 + + do i2=1,support + jj=ind2(count3+1-i2) + Jac4=coords(jj,:) + jac4(1)=exp(alpha*jac4(1)**xbeta) + call LPMN(order(2)+1,order(2),order(2),jac4(2),PM1,PD1) + weight=ind(jj) + BB(i2,1)=weight + count=1 + do R=order0(1),order(1) + IF (order0(1)==0) THEN + do L1=order0(2),3 + do M=order0(3),min(L1,2) + if((L1+M)==0)cycle + count=count+1 + BB(i2,count)=weight*PM1(M,L1)*dcos(dble(M)*jac4(3)) + if (ab_flag==2) then + BB(i2+support,count)=0d0 + BB(i2+2*support,count)=weight*PD1(M,L1)*dcos(dble(M)*jac4(3)) + BB(i2+3*support,count)=weight*PM1(M,L1)*(-dble(M)*dsin(dble(M)*jac4(3))) + endif + enddo + enddo + ELSE + do L1=order0(2),order(2) + do M=order0(3),min(L1,order(3)) + count=count+1 + BB(i2,count)=weight*(jac4(1))**(R)*PM1(M,L1)*dcos(dble(M)*jac4(3)) + if (ab_flag==2) then + BB(i2+support,count)=weight*dble(R)*alpha*xbeta*(jac4(1))**(xbeta-1d0)* & + (jac4(1))**(R)*PM1(M,L1)*dcos(dble(M)*jac4(3)) + BB(i2+2*support,count)=weight*(jac4(1))**(R)*PD1(M,L1)*dcos(dble(M)*jac4(3)) + BB(i2+3*support,count)=weight*(jac4(1))**(R)*PM1(M,L1)*(-dble(M)*dsin(dble(M)*jac4(3))) + endif + enddo + enddo + ENDIF + enddo + enddo + + return +end subroutine make_matrixBB_rigid3D + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! d i s t _ m e t r i c +! ---------------------------------------------------------------------------------- +! This subroutine computes the "distance-metric" between two given configurations +! +! *** Input *** +! xjac <-- internal coordinates of configuration 1 +! xjac2 <-- internal coordinates of configuration 2 +! +! *** Output *** +! dist <-- computed distance-metric + + +subroutine dist_metric(xjac,xjac2,dist) + + use dynamic_parameters + implicit none + integer :: i,j + real*8 :: xjac(XDIM),xjac2(XDIM),scale,dist,temp(XDIM),pii,x1,x2 + real*8 :: zxjac(3),zxjac2(3) + + pii=dacos(-1d0) + + if (XSYS==1) then + + IF (XDIM==1) THEN + + dist=dabs(xjac(1)-xjac2(1)) + return + + ELSEIF (XDIM==2) then! use the same dist_metric as if XDIM=3 + + if (XBAS==0) then + if (XDIST==0) then + zxjac(1)=xjac(1) + zxjac(2)=xjac(2) + zxjac(3)=0.d0 + zxjac2(1)=xjac2(1) + zxjac2(2)=xjac2(2) + zxjac2(3)=0.d0 + elseif (XDIST==1) then + x1=(1d0-xjac(2)**2)*(1d0-xjac2(2)**2)! sinTH1**2 x sinTH2**2 + x2=xjac(2)*xjac2(2)+dsqrt(x1)! cosTH1*cosTH2 + sinTH1*sinTH2 + dist=(xjac(1)**2)+(xjac2(1)**2)-(2d0*xjac(1)*xjac2(1)*x2) + dist=dsqrt(dist) + return + endif + elseif (XBAS==1) then + zxjac(1)=XXR + zxjac(2)=xjac(1) + zxjac(3)=xjac(2) + zxjac2(1)=XXR + zxjac2(2)=xjac2(1) + zxjac2(3)=xjac2(2) + endif + + ELSEIF (XDIM==3) THEN + zxjac(:)=xjac(:) + zxjac2(:)=xjac2(:) + + ELSEIF (XDIM==4) THEN + scale=W_a! <-- scaling factor for R in dist metric (1/W_a) + temp(1)=((xjac(1)-xjac2(1))*scale)**2! dR**2 x (1/W_a)**2 + temp(2)=(dacos(xjac(2))-dacos(xjac2(2)))**2! dTH1**2 + temp(3)=(dacos(xjac(3))-dacos(xjac2(3)))**2! dTH2**2 + temp(4)=xjac(4)-xjac2(4)! dPHI + if(temp(4)>pii)then + temp(4)=temp(4)-2d0*pii + endif + if(temp(4)<-pii)then + temp(4)=temp(4)+2d0*pii + endif + ! sinTH1**2 x sinTH1p**2 sinTH2**2 x sinTH2p**2 = x1 + x1=(1d0-xjac(2)**2)*(1d0-xjac2(2)**2)*(1d0-xjac(3)**2)*(1d0-xjac2(3)**2) + temp(4)=(temp(4)**2)*dsqrt(x1)! dPHI**2 x sqrt(x1) + dist=0d0 + do i=1,4 + dist=dist+temp(i) + enddo + dist=dsqrt(dist) + return + + ENDIF + + ! distance-metric for XDIM = 2 & 3 (XDIST=0) + scale=W_a! <-- scaling factor for R + temp(1)=((zxjac(1)-zxjac2(1))*scale)**2! dR**2 x (1/W_a)**2 + temp(2)=(dacos(zxjac(2))-dacos(zxjac2(2)))**2! dTH**2 + temp(3)=zxjac(3)-zxjac2(3)! dPHI + if(temp(3)>pii)then + temp(3)=temp(3)-2d0*pii + endif + if(temp(3)<-pii)then + temp(3)=temp(3)+2d0*pii + endif + x1=(1d0-zxjac(2)**2)*(1d0-zxjac2(2)**2)! sinTH**2 x sinTHp**2 + temp(3)=(temp(3)**2)*dsqrt(x1)! dPHI**2 x sqrt(...) = dPHI**2 x |sinTH x sinTHp| + dist=0d0 + do i=1,3 + dist=dist+temp(i) + enddo + dist=dsqrt(dist) + endif + +return +end subroutine dist_metric + +!********************************* A U T O S U R F ******************************* +!=================================================================================== +!----------------------------------------------------------------------------------- +!- - +!- AUTOSURF Package: A set of programs for the automated construction - +!- of Potential Energy Surfaces on van der Waals systems - +!- - +!----------------------------------------------------------------------------------- +!=================================================================================== +!*********************************************************************************** +!- Set of Fortran90 subroutines for "AUTOSURF-PES_rigid4D" PROGRAM - +!*********************************************************************************** + + + +! S U B R O U T I N E S + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! B A S I S _ S I Z E +! ---------------------------------------------------------------------------------- +! Calculate the size of the basis set + +! *** Input *** +! XDIM <-- +! * 3D * +! order(1) <-- maximum power of R = exp(alpha*r) +! order(2) <-- maximum value of L +! * 4D * +! order(1) <-- maximum power of R = exp(alpha*r) +! order(2) <-- maximum value of L1 +! order(3) <-- maximum value of L2 +! order(4) <-- maximum value of L = L1 + L2 +! +! *** Output *** +! basis <-- size of the basis set +! +! ---------------------------------------------------------------------------------- + +subroutine basis_size_rigidXD(order,order0,XDIM,XBAS,basis) + + implicit none + integer :: count,count1,count2,basis,l1,l2,m,XDIM,XBAS + integer :: order(XDIM),order0(XDIM) + + count=0 + count1=0 + count2=0 + if(XDIM==1)then + basis=order(1)+1 + elseif(XDIM==2)then + if(XBAS==0)then + do l1=order0(2),order(2) + count=count+1 + enddo + basis=count*(order(1))+1 + elseif(XBAS==1)then + do l1=order0(1),order(1) + do m=order0(2),l1 + count=count+1 + enddo + enddo + basis=count+1 + return !?? + endif + elseif(XDIM==3)then + if (order0(1)==0) then + do l1=order0(2),3 + do m=order0(3),min(l1,2) + if((l1+m)==0)cycle + count1=count1+1 + enddo + enddo + endif + do l1=order0(2),order(2) + do m=order0(3),min(l1,order(3)) + count=count+1 + enddo + enddo + basis=count*(order(1))+count1+1 + elseif(XDIM==4)then + do l1=order0(2),order(2) + do l2=order0(3),order(3) + if((l1+l2)MaxR) then + MaxR=seed(i,1)! find the point with largest R + Easym=seed_pot(i)! energy for point with largest R is set as asymptote energy + endif + if(seed_pot(i)MinE) then! Highest energy in the high-level ab initio seed grid + MinE=seed_pot(i)! Allows looking for holes + endif + enddo + +return +end subroutine update_mag + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! c h e c k _ a b i n i t i o _ d a t +! ---------------------------------------------------------------------------------- +! + +subroutine check_abinitio_dat(tot,dup,rm,maxpoints,XDIM,NAME2,abflag,natom) + + implicit none + character(len=300) :: f602,f601 + character (len=40) :: NAME2 + character (len=3) :: charid + integer :: i,j,XDIM,tot,ncont,maxpoints,abflag,rm,nid(maxpoints),natom,dup,ncont1 + real*8 :: xx(maxpoints,XDIM),eee(maxpoints),x1 + logical :: logica1 + + write(f601,'( "(I10,",I1,"f20.15,f20.8)" )')XDIM !! AbINITIO.dat & AbINITIO_low.dat + write(f602,'( "(I10,",I1,"f20.15,f20.8,",I3,"f20.8)" )')XDIM,natom*3 !! with gradients + + ncont=0 + NAME2=trim(adjustl(NAME2)) + open(unit=222,file=NAME2,status='old') + + !if(abflag==1) ... + do i=1,maxpoints + read(222,*,end=33)nid(i),xx(i,1:XDIM),eee(i) + ncont=ncont+1 + enddo + 33 continue + tot=ncont! number of ab initio points computed so far... + + ncont=0 + do i=1,tot + do j=i+1,tot + x1=dabs(eee(i)-eee(j)) + if((xx(i,1)==xx(j,1)).and.(x1<=1.d-7))then + write(78,*)i,xx(i,:) + write(78,*)j,xx(j,:) + write(78,*) + ncont=ncont+1! number of duplicated geometries + endif + enddo + enddo + dup=ncont + close(222) + + rm=0 + if (ncont/=0) then + write(78,*)'ab initio points computed so far: ',tot + write(78,*)'number of duplicated points found:',dup + ! check if previous files exist + i=1 + do j=1,98 + write(charid,'(I2)')j + inquire(file=trim(adjustl(NAME2))//'.tofix'//trim(adjustl(charid)),exist=logica1) + if(logica1)then + i=i+1 + else + goto 221 + endif + enddo + 221 write(charid,'(I2)')i + ! make a copy of the AbINITIO file to be modified + call system('mv '//trim(adjustl(NAME2))//' '//trim(adjustl(NAME2))//'.tofix'//trim(adjustl(charid))) + write(6,*)'mv '//trim(adjustl(NAME2))//' '//trim(adjustl(NAME2))//'.tofix'//trim(adjustl(charid)) + ncont=0 + open(unit=222,file=NAME2,status='new') + do i=1,tot + ncont1=0 + do j=i+1,tot + x1=dabs(eee(i)-eee(j)) + if((xx(i,1)==xx(j,1)).and.(x1<=1.d-7))then + ncont1=ncont1+1 + endif + enddo + if (ncont1==0) then + ncont=ncont+1! number of non-duplicated geometries + write(222,f601)nid(i),xx(i,:),eee(i) + endif + enddo + rm=tot-ncont + write(78,*)'removed geometries: ',rm + write(78,*) + endif + close(222) + + return +end subroutine check_abinitio_dat + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! s e a r c h _ a b i n i t i o _ d a t +! ---------------------------------------------------------------------------------- +! + +subroutine search_abinitio_dat(x,maxpoints,XDIM,NAME2,abflag,natom,xdist,control,flag) + + implicit none + character(len=300) :: f602,f601 + character (len=40) :: NAME2 + integer :: i,j,XDIM,maxpoints,abflag,nid,natom,flag,ncont,ncont1,control + real*8 :: x(XDIM), xx(XDIM),x1,xgrad(3*natom),xdist,local_d + logical :: logica1 + integer,allocatable :: ind2(:) + real*8,allocatable :: ind(:) + + write(f601,'( "(I10,",I1,"f20.14,f20.8)" )')XDIM !! AbINITIO.dat & AbINITIO_low.dat + write(f602,'( "(I10,",I1,"f20.14,f20.8,",I3,"f20.8)" )')XDIM,natom*3 !! with gradients + + NAME2=trim(adjustl(NAME2)) + + flag=0 + + IF (control==0) THEN ! check if the geometry is already included in AbINITIO.dat + + open(unit=222,file=NAME2,status='old',action='read') + do i=1,maxpoints + if(abflag==1)read(222,*,end=33)nid,xx(:),x1 + if(abflag==2)read(222,*,end=33)nid,xx(:),x1,xgrad(:) + ncont=0 + do j=1,XDIM + if (dabs(x(j)-xx(j))<=1.d-5) ncont=ncont+1 + enddo + if (ncont==XDIM) then + flag=1 + goto 33 + endif + enddo + 33 close(222) + return + + ELSEIF (control==1) THEN ! check for previous geometries in the same region (similar configurations) + + !find the number of geometries already included in AbINITIO.dat + open(unit=222,file=NAME2,status='old',action='read') + ncont=0 + do i=1,maxpoints + if(abflag==1)read(222,*,end=34) + if(abflag==2)read(222,*,end=34) + ncont=ncont+1 + enddo + 34 close(222) + + !find closest geometry in AbINITIO.dat + allocate(ind(ncont),ind2(ncont)) + open(unit=222,file=NAME2,status='old',action='read') + do i=1,ncont! compute "d" + if(abflag==1)read(222,*)nid,xx(:),x1 + if(abflag==2)read(222,*)nid,xx(:),x1,xgrad(:) + call dist_metric(x,xx,ind(i)) + enddo + close(222) + call indexxy(ncont,ind,ind2) + local_d=ind(ind2(1)) + if (local_d MAXBIT) call nrerror('MAXBIT too small in sobseq') + im=(j-1)*MAXDIM + j=min(size(x),MAXDIM) + ! XOR the appropriate direction number into each component of the vector + ! and convert to a floating number. + ix(1:j)=ieor(ix(1:j),iv(1+im:j+im)) + x(1:j)=ix(1:j)*fac + in=in+1! Increment the counter. +end if + +END SUBROUTINE sobseq + + + + +!*********************************************************************************************** + + +subroutine fact(n,p) + integer :: n,p,i + p=1 + do i=1,n + p=p*i + enddo +end subroutine fact + +subroutine binomial(n,m,b) + integer :: n,m,b,num,denom1,denom2,p + call fact(n,p) + num=p + call fact(n-m,p) + denom1=p + call fact(m,p) + denom2=p + b=num/(denom1*denom2) +end subroutine binomial + +subroutine beta_term(j,m,mp,x,dx,ddx) + implicit none + integer :: j,m,mp,n,k,cof1,cof2,cof3,lam + real*8 :: x,px,dx,ddx,theta,ddpx,temp,alfa,beta + k=min(j+m,j-m,j+mp,j-mp) + if(k==j+m)then + alfa=dble(mp-m) + lam=mp-m + endif + if(k==j-m)then + alfa=dble(m-mp) + lam=0 + endif + if(k==j+mp)then + alfa=dble(m-mp) + lam=0 + endif + if(k==j-mp)then + alfa=dble(mp-m) + lam=mp-m + endif + beta=dble(2*j)-dble(2*k)-alfa + call jacobi_pol(k,alfa,beta,x,px) + cof1=(-1)**lam + call binomial(2*j-k,int(k+alfa),cof2) + call binomial(int(k+beta),int(beta),cof3) + dx=dble(cof1)*(dble(cof2)**0.5d0)*(dble(cof3)**(-0.5d0))*(dsqrt((1d0-x)/2d0)**alfa)*(dsqrt((1d0+x)/2d0)**beta)*px + call jacobi_pol(k-1,alfa+1d0,beta+1d0,x,ddpx) + ddpx=0.5d0*dble(k+alfa+beta+1)*ddpx + temp=(beta*dsqrt(0.5d0-x/2d0)**alfa*((x+1d0)/2d0)**(-1d0+dble(beta)/2d0)- & + alfa*((1d0-x)/2d0)**(-1d0+dble(alfa)/2d0)*dsqrt((x+1d0)/2d0)**(beta))/4d0 + ddx=dble(cof1)*(dble(cof2)**0.5d0)*(dble(cof3)**(-0.5d0))* & + (ddpx*(dsqrt((1d0-x)/2d0)**alfa)*(dsqrt((1d0+x)/2d0)**beta)+ (temp)*px) + return +end subroutine beta_term + + + +subroutine jacobi_pol(n,alfa,beta,x,px) + implicit none + integer :: i,n + real*8 :: alfa,beta,cx(0:n),x,c1,c2,c3,c4,px + if (n<0) then + px=0d0 + return + endif + cx(0)=1d0 + if (n==0) then + px=cx(n) + return + endif + cx(1)=(1.0d0+0.5d0*(alfa+beta))*x+0.5d0*(alfa-beta) + do i=2,n + c1=2.0d0*dble(i)*(dble(i)+alfa+beta)*(dble(2*i-2)+alfa+beta) + c2=(dble(2*i-1)+alfa+beta)*(dble(2*i)+alfa+beta)*(dble(2*i-2)+alfa+beta) + c3=(dble(2*i-1)+alfa+beta)*(alfa+beta)*(alfa-beta) + c4=-dble(2)*(dble(i-1)+alfa)*(dble(i-1)+beta)*(dble(2*i)+alfa+beta) + cx(i)=((c3+c2*x)*cx(i-1)+c4*cx(i-2))/c1 + enddo + px=cx(n) + return +end subroutine jacobi_pol + + + +!!$!-----------------------------------------------------------------------! +subroutine map_int(inter) + + implicit none + real*8 :: inter(4),internal(2,4) + internal(1,:)=inter(:) + internal(2,:)=inter(:) + internal(2,2)=-internal(1,3) + internal(2,3)=-internal(1,2) + if(internal(1,2)p + xicom=>xi + ax=0.0 + xx=1.0 + call mnbrak(ax,xx,bx,fa,fx,fb,f1dim) + fret=dbrent(ax,xx,bx,f1dim,df1dim,TOL,xmin) + xi=xmin*xi + p=p+xi + END SUBROUTINE dlinmin + + +!c----------------------------------------------------------------------- +!c----------------------------------------------------------------------- +!c----------------------------------------------------------------------- + +!!! frprmn.f90 +!c----------------------------------------------------------------------- + + + SUBROUTINE frprmn(p,ftol,iter,fret) + USE nrtype; USE nrutil, ONLY : nrerror + USE nr, ONLY : dlinmin + IMPLICIT NONE + INTEGER(I4B), INTENT(OUT) :: iter + REAL*8, INTENT(IN) :: ftol + REAL*8, INTENT(OUT) :: fret + REAL*8, DIMENSION(:), INTENT(INOUT) :: p + INTERFACE + FUNCTION func(p) + USE nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: p + REAL*8 :: func + END FUNCTION func +!BL + FUNCTION dfunc(p) + USE nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: p + REAL*8, DIMENSION(size(p)) :: dfunc + END FUNCTION dfunc + END INTERFACE +! INTEGER(I4B), PARAMETER :: ITMAX=10000 + INTEGER(I4B) :: ITMAX + REAL*8, PARAMETER :: EPS=1.0e-18_sp + INTEGER(I4B) :: its,i + REAL*8 :: dgg,fp,gam,gg + REAL*8, DIMENSION(size(p)) :: g,h,xi,gxi + fp=func(p) + xi=dfunc(p) + g=-xi + h=g + xi=h + ITMAX=size(p)+1 + do its=1,ITMAX + iter=its + call dlinmin(p,xi,fret) +! write(*,*)2.0_sp*abs(fret-fp),ftol*(abs(fret)+abs(fp)+EPS) + if (2.0_sp*abs(fret-fp) <= ftol*(abs(fret)+abs(fp)+EPS)) RETURN + fp=fret + xi=dfunc(p) +! write(*,*) its,fcalls,maxval(dabs(xi)),fp + gg=dot_product(g,g) +! dgg=dot_product(xi,xi) + dgg=dot_product(xi+g,xi) + if (gg == 0.0) RETURN + gam=dgg/gg + g=-xi + h=g+gam*h + xi=h + end do +! call nrerror('frprmn: maximum iterations exceeded') + END SUBROUTINE frprmn + + + + +!c----------------------------------------------------------------------- +!c----------------------------------------------------------------------- +!c----------------------------------------------------------------------- + +!!! mnbrak.f90 +!c----------------------------------------------------------------------- + + + + SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,func) + USE nrtype; USE nrutil, ONLY : swap + IMPLICIT NONE + REAL*8, INTENT(INOUT) :: ax,bx + REAL*8, INTENT(OUT) :: cx,fa,fb,fc + INTERFACE + FUNCTION func(x) + USE nrtype + IMPLICIT NONE + REAL*8, INTENT(IN) :: x + REAL*8 :: func + END FUNCTION func + END INTERFACE + REAL*8, PARAMETER :: GOLD=1.618034_sp,GLIMIT=100.0_sp,TINY=1.0e-20_sp + REAL*8 :: fu,q,r,u,ulim + fa=func(ax) + fb=func(bx) + if (fb > fa) then + call swap(ax,bx) + call swap(fa,fb) + end if + cx=bx+GOLD*(bx-ax) + fc=func(cx) + do + if (fb < fc) RETURN + r=(bx-ax)*(fb-fc) + q=(bx-cx)*(fb-fa) + u=bx-((bx-cx)*q-(bx-ax)*r)/(2.0_sp*sign(max(abs(q-r),TINY),q-r)) + ulim=bx+GLIMIT*(cx-bx) + if ((bx-u)*(u-cx) > 0.0) then + fu=func(u) + if (fu < fc) then + ax=bx + fa=fb + bx=u + fb=fu + RETURN + else if (fu > fb) then + cx=u + fc=fu + RETURN + end if + u=cx+GOLD*(cx-bx) + fu=func(u) + else if ((cx-u)*(u-ulim) > 0.0) then + fu=func(u) + if (fu < fc) then + bx=cx + cx=u + u=cx+GOLD*(cx-bx) + call shft(fb,fc,fu,func(u)) + end if + else if ((u-ulim)*(ulim-cx) >= 0.0) then + u=ulim + fu=func(u) + else + u=cx+GOLD*(cx-bx) + fu=func(u) + end if + call shft(ax,bx,cx,u) + call shft(fa,fb,fc,fu) + end do + CONTAINS +!BL + SUBROUTINE shft(a,b,c,d) + REAL*8, INTENT(OUT) :: a + REAL*8, INTENT(INOUT) :: b,c + REAL*8, INTENT(IN) :: d + a=b + b=c + c=d + END SUBROUTINE shft + END SUBROUTINE mnbrak + + + +!c----------------------------------------------------------------------- +!c----------------------------------------------------------------------- +!c----------------------------------------------------------------------- + +!!! index.f90 +!c----------------------------------------------------------------------- + +SUBROUTINE indexxy(n,arr,indx) + INTEGER :: n + integer,parameter :: nstack=50, m=7 + INTEGER ::indx(n),istack(nstack) + REAL*8 :: arr(n) + + INTEGER :: i,indxt,ir,itemp,j,jstack,k,l + REAL*8 :: a + + + do j=1,n + indx(j)=j + enddo + jstack=0 + l=1 + ir=n +1 if(ir-l.lt.M)then + do j=l+1,ir + indxt=indx(j) + a=arr(indxt) + do i=j-1,1,-1 + if(arr(indx(i)).le.a)goto 2 + indx(i+1)=indx(i) + enddo + i=0 +2 indx(i+1)=indxt + enddo + if(jstack.eq.0)return + ir=istack(jstack) + l=istack(jstack-1) + jstack=jstack-2 + else + k=(l+ir)/2 + itemp=indx(k) + indx(k)=indx(l+1) + indx(l+1)=itemp + if(arr(indx(l+1)).gt.arr(indx(ir)))then + itemp=indx(l+1) + indx(l+1)=indx(ir) + indx(ir)=itemp + endif + if(arr(indx(l)).gt.arr(indx(ir)))then + itemp=indx(l) + indx(l)=indx(ir) + indx(ir)=itemp + endif + if(arr(indx(l+1)).gt.arr(indx(l)))then + itemp=indx(l+1) + indx(l+1)=indx(l) + indx(l)=itemp + endif + i=l+1 + j=ir + indxt=indx(l) + a=arr(indxt) +3 continue + i=i+1 + if(arr(indx(i)).lt.a)goto 3 +4 continue + j=j-1 + if(arr(indx(j)).gt.a)goto 4 + if(j.lt.i)goto 5 + itemp=indx(i) + indx(i)=indx(j) + indx(j)=itemp + goto 3 +5 indx(l)=indx(j) + indx(j)=indxt + jstack=jstack+2 + if(jstack.gt.NSTACK)stop 'NSTACK too small in indexx' + if(ir-i+1.ge.j-l)then + istack(jstack)=ir + istack(jstack-1)=i + ir=j-1 + else + istack(jstack)=j-1 + istack(jstack-1)=l + l=i + endif + endif + goto 1 + + + return +end subroutine indexxy + + +subroutine vec_to_mat(cart_perms,cart_mat,natom) +integer :: k,kp,natom +real*8 :: cart_perms(3*natom),cart_mat(3,natom) +do k=1,natom + do kp=1,3 + cart_mat(kp,k)=cart_perms((k-1)*3+kp) + enddo +enddo +return +end subroutine vec_to_mat + +subroutine mat_to_vec(cart_mat,cart_perms,natom) +integer :: k,kp,natom +real*8 :: cart_perms(3*natom),cart_mat(3,natom) +do k=1,natom + do kp=1,3 + cart_perms((k-1)*3+kp)=cart_mat(kp,k) + enddo +enddo +return +end subroutine mat_to_vec + + +subroutine vec_to_mat2(cart_perms,cart_mat,natom) +integer :: k,kp,natom +real*8 :: cart_perms(3*natom),cart_mat(3,natom) +do k=1,natom + do kp=1,3 + cart_mat(kp,k)=cart_perms((k-1)*3+kp) + enddo +enddo +return +end subroutine vec_to_mat2 + +subroutine mat_to_vec2(cart_mat,cart_perms,natom) +integer :: k,kp,natom +real*8 :: cart_perms(3*natom),cart_mat(3,natom) +do k=1,natom + do kp=1,3 + cart_perms((k-1)*3+kp)=cart_mat(kp,k) + enddo +enddo +return +end subroutine mat_to_vec2 + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! p o t e n _ r i g i d X D (xi) +! ---------------------------------------------------------------------------------- +! Evaluate the PES for the rigid XD case: + +! *** Input *** +! xi <-- vector containing the internal coordinates +! order <-* defines the number of terms in the expansion: +! order(1) = maximum power of R = exp(alpha*r) +! order(2) = maximum value of L1 +! order(3) = maximum value of L2 +! order(4) = maximum value of L ( = L1 + L2 ) +! count3 <-* number of ab initio points included in the fit (including symm. partners) +! coords <-* +! d <-* +! BBB <-* +! symparts <-- number of symmetry partners for each ab initio point +! maxpoints <-- max. number of points +! alpha <-- +! xbeta <-- +! epss <-- +! zz <-* +! basis <-* +! XDIM +! XBAS + +! *** Output *** +! poten <-- + +! actual: call poten_rigid4D(temp,xi, order, count3, coords, d, b2, symparts,maxpoints,alpha,xbeta,epss, zz, basis_1) +! lower: call poten_rigid4D(temp,xi, order-1, count3, coords, d, b2_lower, symparts,maxpoints,alpha,xbeta,epss, zz, basis_2) +! minimal: call poten_rigid4D(temp,xi, order_min, count3, coords, d, b2_minimal, symparts,maxpoints,alpha,xbeta,epss, zz, basis_3) +! LOW-GRID: call poten_rigid4D(temp,xi, order_low, count_seed, coords_seed, d_seed, b2_seed, symparts,maxpoints,alpha,xbeta,epss, zz_low, basis_4) + +subroutine poten_rigidXD(poten,xi,order,order0,count3,coords,d,BBB,symparts,maxpoints,alpha,xbeta,epss,zz,basis,XDIM,XBAS) + + use nrtype + implicit none + + INTEGER, INTENT(IN) :: XDIM,count3,basis,zz,symparts,maxpoints,XBAS + INTEGER, INTENT(IN) :: order(XDIM),order0(XDIM) + REAL*8, INTENT(IN) :: coords(symparts*maxpoints,XDIM),d(symparts*maxpoints) + REAL*8, INTENT(IN) :: alpha,xbeta,epss,xi(XDIM),BBB(basis,symparts*maxpoints) + REAL*8, INTENT(OUT) :: poten + + integer :: i,j,k,ip,quitt,l1,l2,l3,l4,l,jp,jj,R,M + integer :: count + real*8 :: temp,weight,norm,somme,jac3(XDIM),jac4(XDIM),XXR,RRR + real*8,allocatable :: ind7(:),PM1(:,:),PM2(:,:),PD1(:,:),PD2(:,:) + integer,allocatable :: ind8(:) + +! ---------------------------------------------------------------------------------- + IF (XDIM==1) THEN +! ---------------------------------------------------------------------------------- + allocate(ind7(count3),ind8(count3)) + + jac3=xi + count=0 + ! compute dist. metric between "xi" and every other geometry included in the fit + do ip=1,count3 + count=count+1 + Jac4=coords(ip,:) + call dist_metric(jac3,jac4,somme) + somme=somme**2 + ind7(count)=dexp(-((somme)/d(ip)**2))/(((somme)/d(ip)**2)**(zz/2)+epss) + enddo + call indexxy(count3,ind7,ind8) + quitt=0! number of expansions included in the interpolation + do ip=1,count3 + if(ind7(ind8(count3))/ind7(ind8(count3+1-ip))>1d11) goto 11 + quitt=quitt+1 + enddo + !write(701,*) quitt + + 11 Jac4=jac3 + jac4(1)=dexp(alpha*jac4(1)**xbeta) +! call LPMN(order(2)+1,order(2),order(2),jac4(2),PM1,PD1) +! call LPMN(order(3)+1,order(3),order(3),jac4(3),PM2,PD2) + + norm=0d0 + temp=0d0 + do i=1,quitt + jj=ind8(count3+1-i) + weight=ind7(jj) + norm=norm+weight + temp=temp+weight*BBB(1,jj) + count=1 + do R=1,order(1) + count=count+1 + temp=temp+weight*BBB(count,jj)*(jac4(1))**(R) + enddo + enddo + + poten=temp/norm + +! ---------------------------------------------------------------------------------- + ELSEIF (XDIM==2) THEN +! ---------------------------------------------------------------------------------- + + if (XBAS==0) then + + allocate(ind7(count3),ind8(count3),PM1(0:order(2)+1,0:order(2)+1),PD1(0:order(2)+1,0:order(2)+1)) + + jac3=xi + count=0 + ! compute dist. metric between "xi" and every other geometry included in the fit + do ip=1,count3 + count=count+1 + Jac4=coords(ip,:) + call dist_metric(jac3,jac4,somme) + somme=somme**2 + ind7(count)=dexp(-((somme)/d(ip)**2))/(((somme)/d(ip)**2)**(zz/2)+epss) + enddo + call indexxy(count3,ind7,ind8) + quitt=0! number of expansions included in the interpolation + do ip=1,count3 + if(ind7(ind8(count3))/ind7(ind8(count3+1-ip))>1d11) goto 12 + quitt=quitt+1 + enddo + !write(701,*) quitt + + 12 Jac4=jac3 + jac4(1)=dexp(alpha*jac4(1)**xbeta) + call LPMN(order(2)+1,order(2),order(2),jac4(2),PM1,PD1) + + norm=0d0 + temp=0d0 + do i=1,quitt + jj=ind8(count3+1-i) + weight=ind7(jj) + norm=norm+weight + temp=temp+weight*BBB(1,jj) + count=1 + do R=1,order(1) + do L1=0,order(2) + count=count+1 + temp=temp+weight*BBB(count,jj)*(jac4(1))**(R)*PM1(0,L1) + enddo + enddo + enddo + + poten=temp/norm + + elseif (XBAS==1) then !! corregir! XRR needed + + !order_1=order(1) + allocate(ind7(count3),ind8(count3),PM1(0:order(1)+1,0:order(1)+1),PD1(0:order(1)+1,0:order(1)+1)) + + jac3=xi! compute and order "distance-metric" between every geometry and xi + count=0 + do ip=1,count3 + count=count+1 + Jac4=coords(ip,:) + call dist_metric(jac3,jac4,somme) + somme=somme**2 + ind7(count)=dexp(-((somme)/d(ip)**2))/(((somme)/d(ip)**2)**(zz/2)+epss) + enddo + call indexxy(count3,ind7,ind8) + quitt=0! number of expansions included in the interpolation + do ip=1,count3 + if(ind7(ind8(count3))/ind7(ind8(count3+1-ip))>1d11) goto 13 + quitt=quitt+1 + enddo + + 13 Jac4=jac3 + RRR=dexp(alpha*XXR) !! corregir! XRR needed + call LPMN(order(1)+1,order(1),order(1),jac4(1),PM1,PD1) + + norm=0d0 + temp=0d0 + do i=1,quitt + jj=ind8(count3+1-i) + ! if(pot(jj)1d11) goto 14 + quitt=quitt+1 + enddo + !write(701,*) quitt + + 14 Jac4=jac3 + jac4(1)=dexp(alpha*jac4(1)**xbeta) + call LPMN(order(2)+1,order(2),order(2),jac4(2),PM1,PD1) + + norm=0d0 + temp=0d0 + do i=1,quitt + jj=ind8(count3+1-i) + ! if(pot(jj)1d11) goto 15 + quitt=quitt+1 + enddo + !write(701,*) quitt + + 15 Jac4=jac3 + jac4(1)=dexp(alpha*jac4(1)**xbeta) + call LPMN(order(2)+1,order(2),order(2),jac4(2),PM1,PD1) + call LPMN(order(3)+1,order(3),order(3),jac4(3),PM2,PD2) + + norm=0d0 + temp=0d0 + do i=1,quitt + jj=ind8(count3+1-i) + ! if(pot(jj)1d11) goto 12 + norm=norm+ind7(ind8(count3+1-ip))! normalization factor for the weight function + quitt=quitt+1! total number of expansions included in the interpolation to obtain V(xi) + enddo + + 12 allocate(weight_grad(quitt,XDIM)) + allocate(PM1(0:order(2)+1,0:order(2)+1),PD1(0:order(2)+1,0:order(2)+1)) + + ! compute derivatives of the weighting function W(xi) + weight_grad=0d0 + norm_grad=0d0 + do i=1,quitt + jj=ind8(count3+1-i) + Jac4=coords(jj,:) + call dist_metric(jac3,jac4,somme) + somme=somme**2! distance metric(**2) + + if (XDIST==0) then + jac4(1)=(jac3(1)-jac4(1))*(W_a**2)! dR x (1/W_a)**2 + jac4(2)=-1.d0*(dacos(jac3(2))-dacos(jac4(2)))/dsqrt(1d0-jac3(2)**2)! dTH1 / |sin(TH1)| + elseif (XDIST==1) then + x1=(1d0-jac3(2)**2)*(1d0-jac4(2)**2)! sinTH1**2 x sinTH2**2 + x1=jac3(2)*jac4(2)+dsqrt(x1)! cosTH1*cosTH2 + sinTH1*sinTH2 + x2=jac4(1)! R2 + jac4(1)=jac3(1)-(jac4(1)*x1)! R1 - R2*(x1) + x1=-1d0*dsqrt(1d0-jac3(2)**2)*jac4(2)+jac3(2)*dsqrt(1d0-jac4(2)**2)! - sinTH1*cosTH2 + cosTH1*sinTH2 + jac4(2)=jac3(1)*x2*x1! R1*R2*(x1) + endif + somme2=somme/(d(jj)**2)! (d/chi)**2 + temp=0d0 + if(somme>1d-10)then + do ip=1,XDIM + temp(ip)=Jac4(ip)*(-2d0)*ind7(ind8(count3+1-i))*& + ((1.0d0/(d(jj)**2))+(zz/2)*((somme2**(zz/2))/((somme2**(zz/2))+epss))*(1.0d0/(somme))) + enddo + else + temp=0d0 + endif + weight_grad(i,:)=temp! derivatives of the weighting function W(xi) + do ip=1,XDIM + norm_grad(ip)=norm_grad(ip)+weight_grad(i,ip) + enddo + enddo + + +!! ! compute derivatives of the weighting function W(xi) +!! weight_grad=0d0 +!! norm_grad=0d0 +!! do i=1,quitt +!! jj=ind8(count3+1-i) +!! Jac4=coords(jj,:) +!! call dist_metric(jac3,jac4,somme) +!! somme=somme**2! distance metric(**2) +!! x1=(1d0-jac3(2)**2)*(1d0-jac4(2)**2)! sinTH1**2 x sinTH2**2 +!! x1=jac3(2)*jac4(2)+dsqrt(x1)! cosTH1*cosTH2 + sinTH1*sinTH2 +!! x2=jac4(1) +!! jac4(1)=jac3(1)-(jac4(1)*x1)! R1 - R2*(x1) +!! x1=-1d0*dsqrt(1d0-jac3(2)**2)*jac4(2)+jac3(2)*dsqrt(1d0-jac4(2)**2)! - sinTH1*cosTH2 + cosTH1*sinTH2 +!! jac4(2)=jac3(1)*x2*x1! R1*R2*(x1) +!! somme2=somme/(d(jj)**2)! (d/chi)**2 +!! temp=0d0 +!! if(somme>1d-10)then +!! do ip=1,XDIM +!! temp(ip)=Jac4(ip)*(-2d0)*ind7(ind8(count3+1-i))*& +!! ((1.0d0/(d(jj)**2))+(zz/2)*((somme2**(zz/2))/((somme2**(zz/2))+epss))*(1.0d0/(somme))) +!! enddo +!! else +!! temp=0d0 +!! endif +!! weight_grad(i,:)=temp! derivatives of the weighting function W(xi) +!! do ip=1,XDIM +!! norm_grad(ip)=norm_grad(ip)+weight_grad(i,ip) +!! enddo +!! enddo + + + ! write(6,*)temp(2),Jac4(2),0.5d0*dsqrt((1d0-jac3(2)**2)*(1d0-jac4(2)**2)*(1d0-jac3(2)**2)),jac3(2) + + temp2=0d0 + Jac4=jac3 + jac4(1)=dexp(alpha*jac4(1)**xbeta) + call LPMN(order(2)+1,order(2),order(2),jac4(2),PM1,PD1) + do i=1,quitt + jj=ind8(count3+1-i) + ! if(pot(jj)1d11) goto 13 + norm=norm+ind7(ind8(count3+1-ip))! normalization factor for the weight function + quitt=quitt+1! total number of expansions included in the interpolation to obtain V(xi) + enddo + + 13 allocate(weight_grad(quitt,XDIM)) + allocate(PM1(0:order(1)+1,0:order(1)+1),PD1(0:order(1)+1,0:order(1)+1)) + + ! compute derivatives of the weighting function W(xi) + weight_grad=0d0 + norm_grad=0d0 + do i=1,quitt + jj=ind8(count3+1-i) + Jac4=coords(jj,:) + scale=dsqrt((1d0-jac3(1)**2)*(1d0-jac4(1)**2))! |sin(TH1)sin(TH1p)| + call dist_metric(jac3,jac4,somme) + somme=somme**2! (distance metric)**2 + jac4(1)=(dacos(jac3(1))-dacos(jac4(1)))/dsqrt(1d0-jac3(1)**2)! dTH1 / |sin(TH1)| ! * (-1)?? + jac4(2)=jac3(2)-jac4(2)! dPHI + ! make sure angle "phi" is always in the correct range + if(jac4(2)>pii)then + jac4(2)=jac4(2)-2d0*pii + endif + if(jac4(2)<-pii)then + jac4(2)=jac4(2)+2d0*pii + endif + jac4(2)=jac4(2)*scale! dPHI * |sin(TH1)sin(TH1p)sin(TH2)sin(TH2p)| + somme2=somme/(d(jj)**2)! (d/chi)**2 + temp=0d0 + if(somme>1d-10)then + do ip=1,XDIM + temp(ip)=Jac4(ip)*(-2d0)*ind7(ind8(count3+1-i))*& + ((1.0d0/(d(jj)**2))+(zz/2)*((somme2**(zz/2))/((somme2**(zz/2))+epss))*(1.0d0/(somme))) + enddo + else + temp=0d0 + endif + weight_grad(i,:)=temp! derivatives of the weighting function W(xi) + do ip=1,XDIM + norm_grad(ip)=norm_grad(ip)+weight_grad(i,ip) + enddo + enddo + + ! write(6,*)temp(1),Jac4(1),0.5d0*dsqrt((1d0-jac3(1)**2)*(1d0-jac4(1)**2)*(1d0-jac3(1)**2)),jac3(1) + + temp2=0d0 + Jac4=jac3 + RRR=dexp(alpha*XXR**xbeta) !! eliminar RRR + do i=1,quitt + jj=ind8(count3+1-i) + ! if(pot(jj)1d11) goto 14 + norm=norm+ind7(ind8(count3+1-ip))! normalization factor for the weight function + quitt=quitt+1! total number of expansions included in the interpolation to obtain V(xi) + enddo + + 14 allocate(weight_grad(quitt,XDIM)) + allocate(PM1(0:order(2)+1,0:order(2)+1),PD1(0:order(2)+1,0:order(2)+1)) + + ! compute derivatives of the weighting function W(xi) + weight_grad=0d0 + norm_grad=0d0 + do i=1,quitt + jj=ind8(count3+1-i) + Jac4=coords(jj,:) + scale=dsqrt((1d0-jac3(2)**2)*(1d0-jac4(2)**2))! |sin(TH1)sin(TH1p)| + call dist_metric(jac3,jac4,somme) + somme=somme**2! distance metric(**2) + jac4(1)=(jac3(1)-jac4(1))*(W_a**2)! dR x (1/W_a)**2 + +! jac4(2)=(dacos(jac3(2))-dacos(jac4(2)))/dsqrt(1d0-jac3(2)**2)! dTH1 / |sin(TH1)| + + jac4(2)=-1.d0*(dacos(jac3(2))-dacos(jac4(2)))/dsqrt(1d0-jac3(2)**2) - & + (jac3(3)-jac4(3))**2*(0.5d0*dsqrt(1d0-jac4(2)**2)*jac3(2)) + + jac4(3)=jac3(3)-jac4(3)! dPHI + ! make sure angle "phi" is always in the correct range + if(jac4(3)>pii)then + jac4(3)=jac4(3)-2d0*pii + endif + if(jac4(3)<-pii)then + jac4(3)=jac4(3)+2d0*pii + endif + jac4(3)=jac4(3)*scale! dPHI * |sin(TH1)sin(TH1p)sin(TH2)sin(TH2p)| + somme2=somme/(d(jj)**2)! (d/chi)**2 + temp=0d0 + if(somme>1d-10)then + do ip=1,XDIM + temp(ip)=Jac4(ip)*(-2d0)*ind7(ind8(count3+1-i))*& + ((1.0d0/(d(jj)**2))+(zz/2)*((somme2**(zz/2))/((somme2**(zz/2))+epss))*(1.0d0/(somme))) + enddo + else + temp=0d0 + endif + weight_grad(i,:)=temp! derivatives of the weighting function W(xi) + do ip=1,XDIM + norm_grad(ip)=norm_grad(ip)+weight_grad(i,ip) + enddo + enddo + +! write(6,*)temp(2),Jac4(2),0.5d0*dsqrt((1d0-jac3(2)**2)*(1d0-jac4(2)**2)*(1d0-jac3(2)**2)),jac3(2) + + temp2=0d0 + Jac4=jac3 + jac4(1)=dexp(alpha*jac4(1)**xbeta) + call LPMN(order(2)+1,order(2),order(2),jac4(2),PM1,PD1) + do i=1,quitt + jj=ind8(count3+1-i) + ! if(pot(jj)1d11) goto 15 + norm=norm+ind7(ind8(count3+1-ip))! normalization factor for the weight function + quitt=quitt+1! total number of expansions included in the interpolation to obtain V(xi) + enddo + + 15 allocate(weight_grad(quitt,XDIM)) + allocate(PM1(0:order(2)+1,0:order(2)+1),PM2(0:order(3)+1,0:order(3)+1)) + allocate(PD1(0:order(2)+1,0:order(2)+1),PD2(0:order(3)+1,0:order(3)+1)) + + ! compute derivatives of the weighting function W(xi) + weight_grad=0d0 + norm_grad=0d0 + do i=1,quitt + jj=ind8(count3+1-i) + Jac4=coords(jj,:) + scale=dsqrt((1d0-jac3(2)**2)*(1d0-jac4(2)**2)*(1d0-jac3(3)**2)*(1d0-jac4(3)**2))! |sin(TH1)sin(TH1p)sin(TH2)sin(TH2p)| + call dist_metric(jac3,jac4,somme) + somme=somme**2! distance metric(**2) + jac4(1)=(jac3(1)-jac4(1))*(W_a**2)! dR x (1/W_a)**2 + !jac4(2)=(dacos(jac3(2))-dacos(jac4(2)))/dsqrt(1d0-jac3(2)**2)! dTH1 / |sin(TH1)| + !jac4(3)=(dacos(jac3(3))-dacos(jac4(3)))/dsqrt(1d0-jac3(3)**2)! dTH2 / |sin(TH2)| + + jac4(2)=-1.d0*(dacos(jac3(2))-dacos(jac4(2)))/dsqrt(1d0-jac3(2)**2) - & + (jac3(4)-jac4(4))**2*(0.5d0*scale*jac3(2)/dsqrt(1d0-jac3(2)**2)) + + jac4(3)=-1.d0*(dacos(jac3(3))-dacos(jac4(3)))/dsqrt(1d0-jac3(3)**2) - & + (jac3(4)-jac4(4))**2*(0.5d0*scale*jac3(3)/dsqrt(1d0-jac3(3)**2)) + + + + +! jac4(2)=(dacos(jac3(2))-dacos(jac4(2)))+0.5d0*dsqrt((1d0-jac3(2)**2)*(1d0-jac3(3)**2)*(1d0-jac4(3)**2))*jac4(2)*(jac3(4)-jac4(4))**2 +! jac4(3)=(dacos(jac3(3))-dacos(jac4(3)))+0.5d0*dsqrt((1d0-jac3(2)**2)*(1d0-jac4(2)**2)*(1d0-jac3(3)**2))*jac4(3)*(jac3(4)-jac4(4))**2 + +! jac4(2)=(dacos(jac3(2))-dacos(jac4(2)))+0.5d0*dsqrt((1d0-jac4(2)**2)*(1d0-jac3(3)**2)*(1d0-jac4(3)**2))*jac3(2)*(jac3(4)-jac4(4))**2 +! jac4(3)=(dacos(jac3(3))-dacos(jac4(3)))+0.5d0*dsqrt((1d0-jac3(2)**2)*(1d0-jac4(2)**2)*(1d0-jac4(3)**2))*jac3(3)*(jac3(4)-jac4(4))**2 + +! jac4(2)=(dacos(jac3(2))-dacos(jac4(2)))/dsqrt(1d0-jac3(2)**2) + & +! (0.5d0*dsqrt((1d0-jac4(2)**2)*(1d0-jac3(3)**2)*(1d0-jac4(3)**2))*jac3(2)*((jac3(4)-jac4(4))**2))/dsqrt(1d0-jac3(2)**2) +! jac4(3)=(dacos(jac3(3))-dacos(jac4(3)))/dsqrt(1d0-jac3(3)**2) + & +! 0.5d0*dsqrt((1d0-jac3(2)**2)*(1d0-jac4(2)**2)*(1d0-jac4(3)**2))*jac3(3)*(jac3(4)-jac4(4))**2/dsqrt(1d0-jac3(3)**2) + jac4(4)=jac3(4)-jac4(4)! dPHI + ! make sure angle "phi" is always in the correct range + if(jac4(4)>pii)then + jac4(4)=jac4(4)-2d0*pii + endif + if(jac4(4)<-pii)then + jac4(4)=jac4(4)+2d0*pii + endif + +! jac4(2)=(dacos(jac3(2))-dacos(jac4(2)))/dsqrt(1d0-jac3(2)**2) + & +! jac4(4)**2*scale*jac4(2)/dsqrt(1d0-jac3(2)**2) +! jac4(2)=(dacos(jac3(2))-dacos(jac4(2)))/dsqrt(1d0-jac3(2)**2) + & +! jac4(4)**2*0.5d0*dsqrt((1d0-jac4(2)**2)*(1d0-jac3(3)**2)*(1d0-jac4(3)**2))*jac3(2)/dsqrt(1d0-jac3(2)**2) + + + + jac4(4)=jac4(4)*scale! dPHI * |sin(TH1)sin(TH1p)sin(TH2)sin(TH2p)| + somme2=somme/(d(jj)**2)! (d/chi)**2 + temp=0d0 + if(somme>1d-10)then + do ip=1,XDIM + temp(ip)=Jac4(ip)*(-2d0)*ind7(ind8(count3+1-i))*& + ((1.0d0/(d(jj)**2))+(zz/2)*((somme2**(zz/2))/((somme2**(zz/2))+epss))*(1.0d0/(somme))) + enddo + else + temp=0d0 + endif + weight_grad(i,:)=temp! derivatives of the weighting function W(xi) + do ip=1,XDIM + norm_grad(ip)=norm_grad(ip)+weight_grad(i,ip) + enddo + enddo + +! write(6,*)temp(3),Jac4(3),0.5d0*dsqrt((1d0-jac3(2)**2)*(1d0-jac4(2)**2)*(1d0-jac3(3)**2)),jac3(3) + + temp2=0d0 + Jac4=jac3 + jac4(1)=dexp(alpha*jac4(1)**xbeta) + call LPMN(order(2)+1,order(2),order(2),jac4(2),PM1,PD1) + call LPMN(order(3)+1,order(3),order(3),jac4(3),PM2,PD2) + do i=1,quitt + jj=ind8(count3+1-i) + ! if(pot(jj)Max_E)then +!!$ factor=1d0+(pot(jj)-Max_E)/E_range +!!$ scale=1d0/factor**2 +!!$ weight=weight*scale +!!$ endif +!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + b(i2)=weight*pot(jj) + if (ab_flag==2) then + do j=1,XDIM + b(i2+j*support)=weight*grad_vec(j) + enddo + endif + enddo + +end subroutine make_matrixb + + + + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! +! ---------------------------------------------------------------------------------- +! Known the internal coordinates for a given configuration: internal2(X), +! the Cartesian coordinates for all atoms in the system are calculated. + +! *** Input *** Internal coordinates: +! internal2 <-- vector containing the internal coordinates + +! XSYS=1 --> two rigid molecules +! * XDIM=1 (Z - axis, two rigid molecules) +! internal2(1) -> R +! * XDIM=2, XBAS=0 (XZ - plane, molecule + atom) +! internal2(1) -> R +! internal2(2) -> cos(theta) +! * XDIM=2, XBAS=1 (theta-phi plane, molecule + atom, R is defined by parameter XXR) +! internal2(1) -> cos(theta) +! internal2(2) -> phi +! * XDIM=3 (molecule + atom) +! internal2(1) -> R +! internal2(2) -> cos(theta) +! internal2(3) -> phi +! * XDIM=4 (two rigid linear molecules) +! internal2(1) -> R +! internal2(2) -> cos(theta1) +! internal2(3) -> cos(theta2) +! internal2(4) -> phi +! +! ---------------------------------------------------------------------------------- + +subroutine exclude_geometries(xcase,internal2,xflag) + + use dynamic_parameters + implicit none + !---------------------------------------------------------------------------------- + ! Interface blocks + INTERFACE! Energy of minimal basis and high-level ab initio + FUNCTION func_actual_min(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_min + END FUNCTION func_actual_min + end interface + INTERFACE! Energy of minimal basis and low-level ab initio + FUNCTION func_actual_seed(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_seed + END FUNCTION func_actual_seed + end interface + INTERFACE! Energy of largest basis and high-level ab initio + FUNCTION func_actual(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual + END FUNCTION func_actual + end interface + INTERFACE! Energy of secondary basis and high-level ab initio + FUNCTION func_actual_lower(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_lower + END FUNCTION func_actual_lower + end interface + !---------------------------------------------------------------------------------- + integer, INTENT(IN) :: xcase + real*8, INTENT(IN) :: internal2(XDIM) + + integer :: i,xflag + real*8 :: pii,temp,temp3 + real*8 :: xcart((natom1+natom2)*3) + real*8,allocatable :: xi(:) + real*8,parameter :: hart2kcl=4.359744650D-18/4184*6.022140857D23 + + allocate(xi(XDIM)) + xi=internal2 + pii=dacos(-1d0) + + xflag=0 + ! EXCLUDE GEOMETRIES ... + + IF (XSYS==1) THEN! (two rigid-fragments systems) + + ! (low-level grid-points selection) + if (xcase==1) then + !... if any pair of atoms are too close + call INT_Cart(xcart,xi) + call cart_to_bdist_inter(xcart,natom1,natom2,dist_tol,xflag) + endif + + ! (high-level grid-points selection) + if (xcase==2) then + !... if any pair of atoms are too close + call INT_Cart(xcart,xi) + call cart_to_bdist_inter(xcart,natom1,natom2,dist_tol,xflag) + if(xflag==1)return + !... if estimated E is higher than "Max_E_seed" + if(low_grid>0)then + if(func_actual_seed(xi)>Max_E_seed)xflag=1 + endif + endif + + ! (Random errors at the beginning of each loop) + if (xcase==3) then + !... if any pair of atoms are too close + call INT_Cart(xcart,xi) + call cart_to_bdist_inter(xcart,natom1,natom2,dist_tol,xflag) + if(xflag==1)return + !... based on energy + if (low_grid>0) then + temp3=func_actual_seed(xi)! (seed-grid-PES estimate + low-grid cutoff) + if(temp3>Max_E_seed)xflag=1! ... if estimated energy is above Max_E_seed + endif + if(xflag==1)return + if(focus_onLR==1)goto 10! avoid energy-focus if only long-range is considered + if (focus>0) then! focus only on the energy range specified in the input file + if(func_actual(xi)>E_asym+(0.05d0/hart2kcl*CONVE)-increment)xflag=1 + else + if (wellfocus>0) then! exclude positive energies if error is already below 3 X acc. target + if(func_actual(xi)>E_asym+(0.05d0/hart2kcl*CONVE))xflag=1 + endif + endif + if(xflag==1)return + 10 continue + ! exclude points with E (min-PES estimate) > E_asym + E_range + if (subzero==0) then + temp=func_actual_min(xi) + if(temp>Max_E)xflag=1 + else + temp=func_actual_min(xi) + if(temp+temp3>Max_E)xflag=1 + endif + endif + + + ! energy-filter with min-PES () + if (xcase==4) then + if (low_grid>0) then + temp3=func_actual_seed(xi)! (seed-grid-PES estimate + low-grid cutoff) + if(temp3>Max_E_seed)xflag=1! ... if estimated energy is above Max_E_seed + endif + if(xflag==1)return + ! exclude points with E (min-PES estimate) > E_asym + E_range + if (subzero==0) then + temp=func_actual_min(xi) + if(temp>Max_E)xflag=1 + else + temp=func_actual_min(xi) + if(temp+temp3>Max_E)xflag=1 + endif + endif + + + + + ENDIF + + + + return +end subroutine exclude_geometries + + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! p o t e n c i a l +! ---------------------------------------------------------------------------------- +! Known the internal coordinates for a given configuration: internal2(X), +! the potential energy value (V) is returned for any of the fitted surfaces. + +! *** Input *** +! xpes = 0 --> func_actual(xi) +! xpes = 1 --> func_actual_lower(xi) +! xpes = 2 --> func_actual_min(xi) +! xpes = 3 --> func_actual_seed(xi) +! xverb --> verbose mode? 0=no, 1=yes +! +! Internal coordinates: +! internal2 <-- vector containing the internal coordinates: +! XSYS=1 --> two rigid molecules +! * XDIM=1 (Z - axis, two rigid molecules) +! internal2(1) -> R +! * XDIM=2, XBAS=0 (XZ - plane, molecule + atom) +! internal2(1) -> R +! internal2(2) -> cos(theta) +! * XDIM=2, XBAS=1 (theta-phi plane, molecule + atom, R is defined by parameter XXR) +! internal2(1) -> cos(theta) +! internal2(2) -> phi +! * XDIM=3 (molecule + atom) +! internal2(1) -> R +! internal2(2) -> cos(theta) +! internal2(3) -> phi +! * XDIM=4 (two rigid linear molecules) +! internal2(1) -> R +! internal2(2) -> cos(theta1) +! internal2(3) -> cos(theta2) +! internal2(4) -> phi +! +! *** Output *** +! V --> potential energy +! xflag --> +! ---------------------------------------------------------------------------------- +subroutine potencial(internal2,V,xpes,xverb,xflag) + + use dynamic_parameters + implicit none + !---------------------------------------------------------------------------------- + ! Interface blocks + INTERFACE! Energy of minimal basis and high-level ab initio + FUNCTION func_actual_min(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_min + END FUNCTION func_actual_min + end interface + INTERFACE! Energy of minimal basis and low-level ab initio + FUNCTION func_actual_seed(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_seed + END FUNCTION func_actual_seed + end interface + INTERFACE! Energy of largest basis and high-level ab initio + FUNCTION func_actual(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual + END FUNCTION func_actual + end interface + INTERFACE! Energy of secondary basis and high-level ab initio + FUNCTION func_actual_lower(xi) + use nrtype + USE dynamic_parameters + IMPLICIT NONE + REAL*8, DIMENSION(:), INTENT(IN) :: xi + REAL*8 :: func_actual_lower + END FUNCTION func_actual_lower + end interface + !---------------------------------------------------------------------------------- + real*8, INTENT(IN) :: internal2(XDIM) + integer, INTENT(IN) :: xpes,xverb + real*8, INTENT(OUT) :: V + integer, INTENT(OUT) :: xflag + + integer :: i + real*8 :: temp,temp1,temp2,temp3 + real*8 :: xcart((natom1+natom2)*3),internal(XDIM) +! real*8,parameter :: hart2kcl=4.359744650D-18/4184*6.022140857D23 + + internal=internal2 + xflag=0 + + IF (XSYS==1) THEN! (two rigid-fragments systems) + + ! set V to the maximum allowed energy if.. + !.. coordinate R is outside fitted range + if(internal(1)0)then + temp3=func_actual_seed(internal) + if(temp3>Max_E_seed)xflag=1 + if(xflag==1)then + if(xverb==1)write(*,*) 'hit ceiling on low grid' + goto 10 + endif + endif + if(xpes==3)goto 10 + !.. if estimated E for min-PES is higher than "Max_E" + if (subzero==0) then + temp2=func_actual_min(internal) + if(temp2>Max_E)xflag=1 + else + temp2=func_actual_min(internal)+temp3 + if(temp2>Max_E)xflag=1 + endif + if(xflag==1)then + if(xverb==1)write(*,*) 'hit ceiling (func_actual_min)' + goto 10 + endif + if(xpes==2)goto 10 + !.. if estimated E for high-PES is higher than "Max_E" + if (subzero==0) then + temp=func_actual(internal) + if(temp>Max_E)xflag=1 + else + temp=func_actual(internal)+temp3 + if(temp>Max_E)xflag=1 + endif + if(xflag==1)then + if(xverb==1)write(*,*) 'hit ceiling (func_actual)' + goto 10 + endif +10 if (xflag==1) then + if (xpes==3) then + V=Max_E_seed + else + V=Max_E + endif + return + else + if (xpes==3) then + V=temp3 + elseif (xpes==2) then + V=temp2 + elseif (xpes==1) then + if (subzero==0) V=func_actual_lower(internal) + if (subzero==1) V=func_actual_lower(internal)+temp3 + elseif (xpes==0) then + V=temp + endif + return + endif + + ENDIF + +end subroutine potencial + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! f i n d _ R o p t +! ---------------------------------------------------------------------------------- +! Known the angular coordinates for a given configuration: internal2(2:XDIM), +! the R-optimized (in energy: V) value is returned: internal2(1). + +! *** Input *** Internal coordinates: +! xacc --> accuracy of the R-optimization: 0.1, 0.01, 0.001, ... +! xcont --> used by? 0=AUTOSURF-PES, 1=AUTOSURF-PLOT +! xr1 --> min. R +! xr2 --> max. R +! xpes = 0 --> func_actual(xi) +! xpes = 1 --> func_actual_lower(xi) +! xpes = 2 --> func_actual_min(xi) +! xpes = 3 --> func_actual_seed(xi) +! xverb --> verbose mode? 0=no, 1=yes +! +! internal2 <-- vector containing the internal coordinates + +! XSYS=1 --> two rigid molecules +! * XDIM=1 (Z - axis, two rigid molecules) +! internal2(1) -> R +! * XDIM=2, XBAS=0 (XZ - plane, molecule + atom) +! internal2(1) -> R +! internal2(2) -> cos(theta) +! * XDIM=2, XBAS=1 (theta-phi plane, molecule + atom, R is defined by parameter XXR) +! internal2(1) -> cos(theta) +! internal2(2) -> phi +! * XDIM=3 (molecule + atom) +! internal2(1) -> R +! internal2(2) -> cos(theta) +! internal2(3) -> phi +! * XDIM=4 (two rigid linear molecules) +! internal2(1) -> R +! internal2(2) -> cos(theta1) +! internal2(3) -> cos(theta2) +! internal2(4) -> phi +! +! *** Output *** +! V --> optimized potential energy +! xflag --> +! ---------------------------------------------------------------------------------- +subroutine find_Ropt(internal2,V,xpes,xverb,xacc,xr1,xr2,xcont,NAME1,xflag) + + use dynamic_parameters + implicit none + !---------------------------------------------------------------------------------- + character (len=40), INTENT(IN) :: NAME1 + real*8, INTENT(IN) :: xacc,xr1,xr2 + integer, INTENT(IN) :: xpes,xverb + real*8, INTENT(OUT) :: V + integer, INTENT(OUT) :: xflag + + integer :: i,k,nxdR,xcont + real*8 :: temp,temp3 + real*8 :: internal(XDIM),internal2(XDIM),xcart((natom1+natom2)*3) + real*8 :: Rtamp,xdR,dR,tampon,tampon1,XXDR!,,,, + + xflag=0 + jac=internal2 + + ! define accuracy parameters + if(xacc<=0.0001d0)then + xxDR=0.0001d0 + nxdR=4 + elseif(xacc<=0.001d0)then + xxDR=0.001d0 + nxdR=3 + elseif(xacc<=0.01d0)then + xxDR=0.01d0 + nxdR=2 + elseif(xacc<=0.1d0)then + XXDR=0.1d0 + nxdR=1 + endif + if(xacc>0.1d0)then + xxDR=0.5d0 + nxdR=1 + endif + + ! make the corresponding R-opt 1D cut of the PES + tampon=400d0 + Rtamp=500d0 + ! 1st scan + xdR=(xr2-xr1)/dble(40) + do k=1,40 + jac(1)=dble(k-1)*xdR+xr1 + if(xcont==0)call potencial(jac,V,xpes,xverb,xflag) + if(xcont==1)call PES(jac,V,NAME1,xpes,xverb) + tampon1=V + if(tampon12.d0*xxdR)then + dR=xdR + xdR=xxdR + do k=1,int((2.0d0*dR)/xdR)+1 + jac(1)=dble(k-1)*xdR+Rtamp-dR + if(xcont==0)call potencial(jac,V,xpes,xverb,xflag) + if(xcont==1)call PES(jac,V,NAME1,xpes,xverb) + tampon1=V + if(tampon10d0)then! for this particular angular configuration no negative energies exist (pure repulsive) + tampon=0d0 + Rtamp=xr2 + xflag=1 + endif + + V=tampon + internal2(1)=Rtamp + return + +end subroutine find_Ropt + + + +!*********************************************************************************** +! ---------------------------------------------------------------------------------- +! f i n d _ m i n D +! ---------------------------------------------------------------------------------- +! Known the internal coordinates for a given configuration: internal2(1:XDIM), the +! minimum distance-metric from geometries already on 'AbINITIO.dat' is returned. + +! *** Input *** +! Internal coordinates: +! internal2 <-- vector containing the internal coordinates +! XSYS=1 --> two rigid molecules +! * XDIM=1 (Z - axis, two rigid molecules) +! internal2(1) -> R +! * XDIM=2, XBAS=0 (XZ - plane, molecule + atom) +! internal2(1) -> R +! internal2(2) -> cos(theta) +! * XDIM=2, XBAS=1 (theta-phi plane, molecule + atom, R is defined by parameter XXR) +! internal2(1) -> cos(theta) +! internal2(2) -> phi +! * XDIM=3 (molecule + atom) +! internal2(1) -> R +! internal2(2) -> cos(theta) +! internal2(3) -> phi +! * XDIM=4 (two rigid linear molecules) +! internal2(1) -> R +! internal2(2) -> cos(theta1) +! internal2(3) -> cos(theta2) +! internal2(4) -> phi +! +! *** Output *** +! Dmin --> minimum distance-metric + +! ---------------------------------------------------------------------------------- +subroutine find_minD(internal2,XDIM,Dmin) + + implicit none + !---------------------------------------------------------------------------------- + integer, INTENT(IN) :: XDIM + real*8, INTENT(IN) :: internal2(XDIM) + real*8, INTENT(OUT) :: Dmin + + integer :: i,ncont,nid + real*8 :: internal(XDIM),internal1(XDIM) + real*8 :: x1 + + internal=internal2 + + ! find how many geometries are in 'AbINITIO.dat' + ncont=0 + open(unit=222,file='AbINITIO.dat',status='old',action='read') + do i=1,1000000 + read(222,*,end=10) + ncont=ncont+1 + enddo + 10 close(222) + + ! find min. distance metric + Dmin=1d21 + open(unit=222,file='AbINITIO.dat',status='old',action='read') + do i=1,ncont + !if(abflag==1)read(222,*,end=20)nid,xx(:),x1 + !if(abflag==2)read(222,*,end=20)nid,xx(:),x1,xgrad(:) + read(222,*,end=20)nid,internal1(:),x1 + call dist_metric(internal,internal1,x1) + if (Dmin 0) THEN + En = En+(C1*C2**n)*Multipole_Energies(n) + END IF + + end do + + + do n = 6,7 + IF (D_Fit(n-5) > 0) THEN + En = En+(C1*C2**n)*Dispersion_Energies(n-5) + END IF + + end do + + do n = 4, 7 + IF (I_Fit(n-3) > 0) THEN + En = En + (C1*C2**n)*Ind_Energ(n-3) + END IF + + end do + + TotalEnergy = 349.755088236337d0*En + + +end SUBROUTINE TotalEnergy_Calc + + + + + + +SUBROUTINE Prep_Param(Coeff_Address, coeff_arr,M_Fit ,D_Fit,I_Fit,Zero) + IMPLICIT NONE + + ! NEED TO DECLARE ALL THE SUBROUTINE ARGUMENTS and + ! ANY OTHER VARIABLES LOCAL TO THE SUBROUTINE + + real*8 , dimension(8) :: A_Mult,B_Mult !q, mz, Qz, Oz, Phiz, M5z, M6z, M7z + real*8 , dimension(12) :: Disp !C6,gamma022,gamma202,gamma22 ,mQA_1020,mQA_1121,mQD_1020,mQD_1121,QmA_1020,QmA_1121,QmD_1020,QmD_1121 + real*8 , dimension(4) :: DDPol !aver_A,diff_A,aver_B,diff_B + real*8 , dimension(4) :: DQPol !alphaA_10_20,alphaA_11_21,alphaB_10_20,alphaB_11_21 + real*8 , dimension(6) :: QQPol !a2020,a2121,a2222,b2020,b2121,b2222 + + real*8 , dimension(42), INTENT(INOUT) :: coeff_arr + + Character(len = 200), INTENT(IN) :: Coeff_Address + + Integer, dimension (8), INTENT(INOUT) :: M_Fit !add this line + Integer, dimension (2), INTENT(INOUT) :: D_Fit !add this line + Integer, dimension (4), INTENT(INOUT) :: I_Fit !add this line + + Real*8 , INTENT(out) :: Zero !add this line + + + Character(len = 20) :: row + Integer , dimension(5) :: DataColumn !R_column,COSb1_column,COSb2_column,alpha_column, Energy Column + + + Open( 10, file = Coeff_Address ) + Read( 10, *) row + read(10, *) DataColumn + + Read( 10, *) row + read(10, *) M_Fit + read(10, *) D_Fit + read(10, *) I_Fit + + Read( 10, *) row + read(10, *) Zero + !write(6,'(F28.13)')Zero + + Read( 10, *) row + read(10, *) A_Mult + + Read( 10, *) row + read(10, *) B_Mult + + Read( 10, *) row + read(10, *) Disp + + Read( 10, *) row + read(10, *) DDPol + + Read( 10, *) row + read(10, *) DQPol + + Read( 10, *) row + read(10, *) QQPol + + close(10) + + + + coeff_arr(1:8) = A_Mult + coeff_arr(9:16) = B_Mult + coeff_arr(17:28) = Disp + coeff_arr(29:32) = DDPol + coeff_arr(33:36) = DQPol + coeff_arr(37:42) = QQPol + + + + + RETURN +END SUBROUTINE Prep_Param + + +! Arg 1 [coordenates] : a coordenate vector [ R , b1, b2, phi] *the angles should be in degrees +! Arg 2 [Coeff_Address] address of the file which contains the longe range expansion coefficients +! Arg 3 [TotalEnergy] Total Energy calculated +SUBROUTINE Long_Range_Potential(coordenates,TotalEnergy) + + IMPLICIT NONE + real*8, INTENT(INOUT) :: TotalEnergy + real*8 ,dimension(4), INTENT(IN) :: coordenates ! the angles are in degree + real*8 , dimension(7):: cal_coord +! Character(len = 200) :: filename ='./files/coefficients.txt' + Character(len = 200) :: filename ='./coefficients.txt' + Integer, dimension (8) :: M_Fit !add this line + Integer, dimension (2):: D_Fit !add this line + Integer, dimension (4):: I_Fit !add this line + real*8 , dimension(42):: coeff_arr + Real*8 :: Zero !add this line + integer :: initflag + save initflag + data initflag /1/ + save coeff_arr ,M_Fit,D_Fit,I_Fit,Zero + + IF(initflag==1)THEN! initialize + CALL Prep_Param(filename,coeff_arr, M_Fit ,D_Fit,I_Fit,Zero) + initflag=2 + ENDIF + + if (coordenates(1)==0d0 .and. coordenates(2)==0d0 .and. coordenates(3)==0d0 .and. coordenates(4)==0d0) THEN + TotalEnergy = Zero + !write(6,*)'testzero', coordenates,TotalEnergy + else + Call Generate_Coordenates (coordenates,cal_coord) + call TotalEnergy_Calc(cal_coord,coeff_arr, M_Fit ,D_Fit,I_Fit,TotalEnergy) + !write(6,*)'test', coordenates,TotalEnergy + !pause + end if + + ! write(*,*)TotalEnergy + +END SUBROUTINE Long_Range_Potential diff --git a/SUBROUTINES_F77.f b/SUBROUTINES_F77.f new file mode 100644 index 0000000..9c108e9 --- /dev/null +++ b/SUBROUTINES_F77.f @@ -0,0 +1,1102 @@ +!####################################################################### + SUBROUTINE DIAG(N,A,NA,D,E) +!####################################################################### +! +! diagonalize the N by N symmetric matrix A, returning ordered +! eigenvalues in D and eigenvectors as columns of A; E is a workspace + IMPLICIT none + integer :: N,NA + REAL*8 :: A(N,N),D(N),E(N) + integer :: ierr=0 + +! TRED2 to tridiagonalise A, TQL2 to obtain eigenvalues and vectors, +! SORT2 to put them both in increasing order of eigenvalue + CALL TRED2(A,N,NA,D,E) + CALL TQL2(N,NA,D,E,A,ierr) + if(ierr.ne.0) stop 'probleme: base d elongation' + CALL SORT2(N,D,A,NA) + + RETURN + END +!----------------------------------------------------------------------- +! +! ###################################################################### + SUBROUTINE TRED2(A,N,NP,D,E) +!####################################################################### +! +! this routine is copied direct from NR, except for the IMPLICIT +! statement and corresponding replacements of 0. by 0D0 +! +! Householder reduction of a real, symmetric, N by N matrix A, stored in +! an NP by NP physical array. On output, A is replaced by the +! orthogonal matrix Q effecting the transformation. D returns the +! diagonal elements of the tridiagonal matrix, and E the off-diagonal +! elements, with E(1)=0. Several statements, as noted in comments, can +! be omitted if only eigenvalues are to be found, in which case A +! contains no useful information on output. Otherwise they are to be +! included. + IMPLICIT none + integer :: I,J,K,L,N,NP + real*8 :: SCALE,F,G,H,HH + REAL*8 :: A(N,N),D(N),E(N) + + DO 18 I=N,2,-1 + L=I-1 + H=0D0 + SCALE=0D0 + IF(L.GT.1) THEN + DO 11 K=1,L + SCALE=SCALE+ABS(A(I,K)) +11 CONTINUE + IF(SCALE.EQ.0D0) THEN + E(I)=A(I,L) + ELSE + DO 12 K=1,L + A(I,K)=A(I,K)/SCALE + H=H+A(I,K)**2 +12 CONTINUE + F=A(I,L) + G=-SIGN(SQRT(H),F) + E(I)=SCALE*G + H=H-F*G + A(I,L)=F-G + F=0D0 + DO 15 J=1,L +! Omit following line if finding only eigenvalues + A(J,I)=A(I,J)/H + G=0D0 + DO 13 K=1,J + G=G+A(J,K)*A(I,K) +13 CONTINUE + DO 14 K=J+1,L + G=G+A(K,J)*A(I,K) +14 CONTINUE + E(J)=G/H + F=F+E(J)*A(I,J) +15 CONTINUE + HH=F/(H+H) + DO 17 J=1,L + F=A(I,J) + G=E(J)-HH*F + E(J)=G + DO 16 K=1,J + A(J,K)=A(J,K)-F*E(K)-G*A(I,K) +16 CONTINUE +17 CONTINUE + ENDIF + ELSE + E(I)=A(I,L) + ENDIF + D(I)=H +18 CONTINUE +! Omit following line if finding only eigenvalues + D(1)=0D0 + E(1)=0D0 + DO 23 I=1,N +! Delete lines from here ... + L=I-1 + IF(D(I).NE.0D0) THEN + DO 21 J=1,L + G=0D0 + DO 19 K=1,L + G=G+A(I,K)*A(K,J) +19 CONTINUE + DO 20 K=1,L + A(K,J)=A(K,J)-G*A(K,I) +20 CONTINUE +21 CONTINUE + ENDIF +! ... to here when finding only eigenvalues + D(I)=A(I,I) +! Also delete lines from here ... + A(I,I)=1D0 + DO 22 J=1,L + A(I,J)=0D0 + A(J,I)=0D0 +22 CONTINUE +! ... to here when finding only eigenvalues +23 CONTINUE + RETURN + END +!----------------------------------------------------------------------- +! + SUBROUTINE SORT2(N,RA,V,NV) +! ###################################################################### +! +! sorts an array RA of length N into ascending numerical order using the +! Heapsort algorithm, and reorders the vectors y in V(x,y) +! correspondingly; WRK is a workspace +! +! this routine is copied direct from the NR routine SORT, except for the +! IMPLICIT statement and the STOP statement, and additional code to +! reorder the vectors +! + IMPLICIT none + integer :: N,NV,L,I,J,K,IR + real*8 :: RRA + REAL*8 :: RA(N),V(N,N),WRK(N) + + IF(N.LT.1) STOP'unnatural length in SORTE' + L=N/2+1 + IR=N +10 CONTINUE + IF(L.GT.1) THEN + L=L-1 + RRA=RA(L) + DO 1 K=1,N + WRK(K)=V(K,L) +1 CONTINUE + ELSE + RRA=RA(IR) + DO 2 K=1,N + WRK(K)=V(K,IR) +2 CONTINUE + RA(IR)=RA(1) + DO 3 K=1,N + V(K,IR)=V(K,1) +3 CONTINUE + IR=IR-1 + IF(IR.EQ.1) THEN + RA(1)=RRA + DO 4 K=1,N + V(K,1)=WRK(K) +4 CONTINUE + RETURN + ENDIF + ENDIF + I=L + J=L+L +20 IF(J.LE.IR) THEN + IF(J.LT.IR) THEN + IF(RA(J).LT.RA(J+1))J=J+1 + ENDIF + IF(RRA.LT.RA(J)) THEN + RA(I)=RA(J) + DO 5 K=1,N + V(K,I)=V(K,J) +5 CONTINUE + I=J + J=J+J + ELSE + J=IR+1 + ENDIF + GO TO 20 + ENDIF + RA(I)=RRA + DO 6 K=1,N + V(K,I)=WRK(K) +6 CONTINUE + GO TO 10 + END + + + +!####################################################################### +!####################################################################### +! + subroutine tql2(nm,n,d,e,z,ierr) + + implicit none + integer i,j,k,l,m,n,ii,l1,l2,nm,mml,ierr + real*8 d(n),e(n),z(nm,n) + real*8 c,c2,c3,dl1,el1,f,g,h,p,r,s,s2,tst1,tst2,pythag +! +! this subroutine is a translation of the algol procedure tql2, +! num. math. 11, 293-306(1968) by bowdler, martin, reinsch, and +! wilkinson. +! handbook for auto. comp., vol.ii-linear algebra, 227-240(1971). +! +! this subroutine finds the eigenvalues and eigenvectors +! of a symmetric tridiagonal matrix by the ql method. +! the eigenvectors of a full symmetric matrix can also +! be found if tred2 has been used to reduce this +! full matrix to tridiagonal form. +! +! on input +! +! nm must be set to the row dimension of two-dimensional +!! array parameters as declared in the calling program +! dimension statement. +! +! n is the order of the matrix. +! +! d contains the diagonal elements of the input matrix. +! +! e contains the subdiagonal elements of the input matrix +! in its last n-1 positions. e(1) is arbitrary. +! +! z contains the transformation matrix produced in the +! reduction by tred2, if performed. if the eigenvectors +! of the tridiagonal matrix are desired, z must contain +! the identity matrix. +! +! on output +! +! d contains the eigenvalues in ascending order. if an +! error exit is made, the eigenvalues are correct but +! unordered for indices 1,2,...,ierr-1. +! +! e has been destroyed. +! +! z contains orthonormal eigenvectors of the symmetric +! tridiagonal (or full) matrix. if an error exit is made, +! z contains the eigenvectors associated with the stored +! eigenvalues. +! +! ierr is set to +! zero for normal return, +! j if the j-th eigenvalue has not been +! determined after 30 iterations. +! +! +! questions and comments should be directed to burton s. garbow, +! mathematics and computer science div, argonne national laboratory +! +! this version dated august 1983. +! +! ------------------------------------------------------------------ +! + ierr = 0 + if (n .eq. 1) go to 1001 +! + do 100 i = 2, n + 100 e(i-1) = e(i) +! + f = 0.0d0 + tst1 = 0.0d0 + e(n) = 0.0d0 +! + do 240 l = 1, n + j = 0 + h = abs(d(l)) + abs(e(l)) + if (tst1 .lt. h) tst1 = h +! .......... look for small sub-diagonal element .......... + do 110 m = l, n + tst2 = tst1 + abs(e(m)) + if (tst2 .eq. tst1) go to 120 +! .......... e(n) is always zero, so there is no exit +! through the bottom of the loop .......... + 110 continue +! + 120 if (m .eq. l) go to 220 + 130 if (j .eq. 30) go to 1000 + j = j + 1 +! .......... form shift .......... + l1 = l + 1 + l2 = l1 + 1 + g = d(l) + p = (d(l1) - g) / (2.0d0 * e(l)) + r=sqrt(p*p+1.0d0) + d(l) = e(l) / (p + sign(r,p)) + d(l1) = e(l) * (p + sign(r,p)) + dl1 = d(l1) + h = g - d(l) + if (l2 .gt. n) go to 145 +! + do 140 i = l2, n + 140 d(i) = d(i) - h +! + 145 f = f + h +! .......... ql transformation .......... + p = d(m) + c = 1.0d0 + c2 = c + el1 = e(l1) + s = 0.0d0 + mml = m - l +! .......... for i=m-1 step -1 until l do -- .......... + do 200 ii = 1, mml + c3 = c2 + c2 = c + s2 = s + i = m - ii + g = c * e(i) + h = c * p + r=sqrt(p*p+e(i)*e(i)) + e(i+1) = s * r + s = e(i) / r + c = p / r + p = c * d(i) - s * g + d(i+1) = h + s * (c * g + s * d(i)) +! .......... form vector .......... + do 180 k = 1, n + h = z(k,i+1) + z(k,i+1) = s * z(k,i) + c * h + z(k,i) = c * z(k,i) - s * h + 180 continue +! + 200 continue +! + p = -s * s2 * c3 * el1 * e(l) / dl1 + e(l) = s * p + d(l) = c * p + tst2 = tst1 + abs(e(l)) + if (tst2 .gt. tst1) go to 130 + 220 d(l) = d(l) + f + 240 continue +! .......... order eigenvalues and eigenvectors .......... + do 300 ii = 2, n + i = ii - 1 + k = i + p = d(i) +! + do 260 j = ii, n + if (d(j) .ge. p) go to 260 + k = j + p = d(j) + 260 continue +! + if (k .eq. i) go to 300 + d(k) = d(i) + d(i) = p +! + do 280 j = 1, n + p = z(j,i) + z(j,i) = z(j,k) + z(j,k) = p + 280 continue +! + 300 continue +! + go to 1001 +! .......... set error -- no convergence to an +! eigenvalue after 30 iterations .......... + 1000 ierr = l + 1001 return + end + +!####################################################################### +C +C David J. Heisterberg +C The Ohio Supercomputer Center +C 1224 Kinnear Rd. +C Columbus, OH 43212-1163 +C (614)292-6036 +C djh@ccl.net djh@ohstpy.bitnet ohstpy::djh +C +C ANALYZE +C analyze the x to y fit and the fitting matrix +C + SUBROUTINE analyz (n, x, y, w, u) + IMPLICIT CHARACTER (A-Z) +C + INTEGER n + DOUBLEPRECISION x (3, n) + DOUBLEPRECISION y (3, n) + DOUBLEPRECISION w (n) + DOUBLEPRECISION u (3, 3) +C + DOUBLEPRECISION err + DOUBLEPRECISION wnorm + DOUBLEPRECISION urnorm (3) + DOUBLEPRECISION ucnorm (3) + INTEGER i, j +C +C find the mean sum of squares error +C + err = 0.0D0 + wnorm = 0.0D0 + DO 10000 i = 1, n + err = err + w (i) * ((y (1, i) - x (1, i)) ** 2 + + & (y (2, i) - x (2, i)) ** 2 + + & (y (3, i) - x (3, i)) ** 2) + wnorm = wnorm + w (i) +10000 CONTINUE + err = SQRT (err / wnorm) +C +C find the row and column norms of u +C + ucnorm (1) = u (1, 1) ** 2 + u (2, 1) ** 2 + u (3, 1) ** 2 + ucnorm (2) = u (1, 2) ** 2 + u (2, 2) ** 2 + u (3, 2) ** 2 + ucnorm (3) = u (1, 3) ** 2 + u (2, 3) ** 2 + u (3, 3) ** 2 + urnorm (1) = u (1, 1) ** 2 + u (1, 2) ** 2 + u (1, 3) ** 2 + urnorm (2) = u (2, 1) ** 2 + u (2, 2) ** 2 + u (2, 3) ** 2 + urnorm (3) = u (3, 1) ** 2 + u (3, 2) ** 2 + u (3, 3) ** 2 +C +C write the error and u norms +C + WRITE (*, *) + DO 11000 i = 1, 3 + WRITE (*, 1000) (u (i, j), j = 1, 3), urnorm (i) +11000 CONTINUE + WRITE (*, *) + WRITE (*, 1000) (ucnorm (j), j = 1, 3), err +C + RETURN +C + 1000 FORMAT (1X, 3E18.10, 4X, E18.10) +C + END +C +C CENTER +C center a molecule about its weighted centroid or other origin +C + SUBROUTINE center (n, x, w, io, o, t) + IMPLICIT CHARACTER (A-Z) +C + INTEGER n + DOUBLEPRECISION x (3, n) + DOUBLEPRECISION w (n) + LOGICAL io + DOUBLEPRECISION o (3) + DOUBLEPRECISION t (3) +C + DOUBLEPRECISION wnorm + INTEGER i +C + IF (io) THEN + t (1) = o (1) + t (2) = o (2) + t (3) = o (3) + ELSE + t (1) = 0.0D0 + t (2) = 0.0D0 + t (3) = 0.0D0 + wnorm = 0.0D0 + DO 10000 i = 1, n + t (1) = t (1) + x (1, i) * SQRT (w (i)) + t (2) = t (2) + x (2, i) * SQRT (w (i)) + t (3) = t (3) + x (3, i) * SQRT (w (i)) + wnorm = wnorm + SQRT (w (i)) +10000 CONTINUE + t (1) = t (1) / wnorm + t (2) = t (2) / wnorm + t (3) = t (3) / wnorm + ENDIF +C + DO 10100 i = 1, n + x (1, i) = x (1, i) - t (1) + x (2, i) = x (2, i) - t (2) + x (3, i) = x (3, i) - t (3) +10100 CONTINUE +C + RETURN + END + +C GENROT +C Generate a left rotation matrix from a normalized rotation axis +C and cosine and sine of the rotation angle. +C +C INPUT +C a - rotation axis +C cost - cosine of rotation angle +C sint - sine of rotation angle +C +C OUTPUT +C u - the rotation matrix +C + SUBROUTINE genrot (a, cost, sint, u) + IMPLICIT CHARACTER (A-Z) +C + DOUBLEPRECISION a (3) + DOUBLEPRECISION cost, sint + DOUBLEPRECISION u (3, 3) +C + u (1, 1) = a (1) ** 2 + (1.0D0 - a (1) ** 2) * cost + u (2, 1) = a (1) * a (2) * (1.0D0 - cost) + a (3) * sint + u (3, 1) = a (1) * a (3) * (1.0D0 - cost) - a (2) * sint +C + u (1, 2) = a (1) * a (2) * (1.0D0 - cost) - a (3) * sint + u (2, 2) = a (2) ** 2 + (1.0D0 - a (2) ** 2) * cost + u (3, 2) = a (2) * a (3) * (1.0D0 - cost) + a (1) * sint +C + u (1, 3) = a (1) * a (3) * (1.0D0 - cost) + a (2) * sint + u (2, 3) = a (2) * a (3) * (1.0D0 - cost) - a (1) * sint + u (3, 3) = a (3) ** 2 + (1.0D0 - a (3) ** 2) * cost +C + RETURN + END +C +C GENXYW +C generate random reference and test molecules and weights +C + SUBROUTINE genxyw (angle, pert, n, x, y, w) + IMPLICIT CHARACTER (A-Z) +C + DOUBLEPRECISION angle + DOUBLEPRECISION pert + INTEGER n + DOUBLEPRECISION x (3, n) + DOUBLEPRECISION y (3, n) + DOUBLEPRECISION w (n) +C + DOUBLEPRECISION u (3, 3) + INTEGER i +C + DOUBLEPRECISION random + EXTERNAL random +C + CALL ranmol (n, y) + CALL ranrot (angle, u) + CALL rotmol (n, y, x, u) + CALL pertur (pert, n, x) + CALL ranrot (angle, u) + CALL rotmol (n, x, x, u) +C + DO 10000 i = 1, n + w (i) = random () +10000 CONTINUE +C + RETURN + END +C +C IDENTM +C generate an identity matrix +C + SUBROUTINE identm (n, np, u) + IMPLICIT CHARACTER (A-Z) +C + INTEGER n, np + DOUBLEPRECISION u (np, n) +C + INTEGER i, j +C + DO 10000 j = 1, n + DO 10010 i = 1, n + u (i, j) = 0.0D0 +10010 CONTINUE + u (j, j) = 1.0D0 +10000 CONTINUE +C + RETURN + END +C +C JACOBI +C Jacobi diagonalizer with sorted output. Same calling sequence as +C EISPACK routine, but must specify nrot! +C + SUBROUTINE jacobi (a, n, np, d, v, nrot) + IMPLICIT CHARACTER (A-Z) +C + INTEGER n, np, nrot + DOUBLEPRECISION a (np, n) + DOUBLEPRECISION d (n) + DOUBLEPRECISION v (np, n) +C + DOUBLEPRECISION onorm, dnorm + DOUBLEPRECISION b, dma, q, t, c, s + DOUBLEPRECISION atemp, vtemp, dtemp + INTEGER i, j, k, l +C + DO 10000 j = 1, n + DO 10010 i = 1, n + v (i, j) = 0.0D0 +10010 CONTINUE + v (j, j) = 1.0D0 + d (j) = a (j, j) +10000 CONTINUE +C + DO 20000 l = 1, nrot + dnorm = 0.0D0 + onorm = 0.0D0 + DO 20100 j = 1, n + dnorm = dnorm + ABS (d (j)) + DO 20110 i = 1, j - 1 + onorm = onorm + ABS (a (i, j)) +20110 CONTINUE +20100 CONTINUE + IF (onorm / dnorm .LE. 0.0D0) GOTO 19999 + DO 21000 j = 2, n + DO 21010 i = 1, j - 1 + b = a (i, j) + IF (ABS (b) .GT. 0.0D0) THEN + dma = d (j) - d (i) + IF (ABS (dma) + ABS (b) .LE. ABS (dma)) THEN + t = b / dma + ELSE + q = 0.5D0 * dma / b + t = SIGN (1.0D0 / (ABS (q) + SQRT (1.0D0 + q * q)), q) + ENDIF + c = 1.0D0 / SQRT (t * t + 1.0D0) + s = t * c + a (i, j) = 0.0D0 + DO 21110 k = 1, i - 1 + atemp = c * a (k, i) - s * a (k, j) + a (k, j) = s * a (k, i) + c * a (k, j) + a (k, i) = atemp +21110 CONTINUE + DO 21120 k = i + 1, j - 1 + atemp = c * a (i, k) - s * a (k, j) + a (k, j) = s * a (i, k) + c * a (k, j) + a (i, k) = atemp +21120 CONTINUE + DO 21130 k = j + 1, n + atemp = c * a (i, k) - s * a (j, k) + a (j, k) = s * a (i, k) + c * a (j, k) + a (i, k) = atemp +21130 CONTINUE + DO 21140 k = 1, n + vtemp = c * v (k, i) - s * v (k, j) + v (k, j) = s * v (k, i) + c * v (k, j) + v (k, i) = vtemp +21140 CONTINUE + dtemp = c * c * d (i) + s * s * d (j) - + & 2.0D0 * c * s * b + d (j) = s * s * d (i) + c * c * d (j) + + & 2.0D0 * c * s * b + d (i) = dtemp + ENDIF +21010 CONTINUE +21000 CONTINUE +20000 CONTINUE +19999 CONTINUE + nrot = l +C + DO 30000 j = 1, n - 1 + k = j + dtemp = d (k) + DO 30100 i = j + 1, n + IF (d (i) .LT. dtemp) THEN + k = i + dtemp = d (k) + ENDIF +30100 CONTINUE + IF (k .GT. j) THEN + d (k) = d (j) + d (j) = dtemp + DO 30200 i = 1, n + dtemp = v (i, k) + v (i, k) = v (i, j) + v (i, j) = dtemp +30200 CONTINUE + ENDIF +30000 CONTINUE +C + RETURN + END +C +C PERTUR +C apply a random perturbation +C + SUBROUTINE pertur (pert, n, x) + IMPLICIT CHARACTER (A-Z) +C + DOUBLEPRECISION pert + INTEGER n + DOUBLEPRECISION x (3, n) +C + INTEGER i, j +C + DOUBLEPRECISION random + EXTERNAL random +C + DO 10000 j = 1, 3 + DO 10010 i = 1, n + x (j, i) = x (j, i) * + & (1.0D0 + 2.0D0 * pert * (0.5D0 - random ())) +10010 CONTINUE +10000 CONTINUE +C + RETURN + END +C +C Q2MAT +C Generate a left rotation matrix from a normalized quaternion +C +C INPUT +C q - normalized quaternion +C +C OUTPUT +C u - the rotation matrix +C + SUBROUTINE q2mat (q, u) + IMPLICIT NONE +C + DOUBLEPRECISION q (0 : 3) + DOUBLEPRECISION u (3, 3) +C + u (1, 1) = q (0) ** 2 + q (1) ** 2 - q (2) ** 2 - q (3) ** 2 + u (2, 1) = 2.0D0 * (q (1) * q (2) - q (0) * q (3)) + u (3, 1) = 2.0D0 * (q (1) * q (3) + q (0) * q (2)) +C + u (1, 2) = 2.0D0 * (q (2) * q (1) + q (0) * q (3)) + u (2, 2) = q (0) ** 2 - q (1) ** 2 + q (2) ** 2 - q (3) ** 2 + u (3, 2) = 2.0D0 * (q (2) * q (3) - q (0) * q (1)) +C + u (1, 3) = 2.0D0 * (q (3) * q (1) - q (0) * q (2)) + u (2, 3) = 2.0D0 * (q (3) * q (2) + q (0) * q (1)) + u (3, 3) = q (0) ** 2 - q (1) ** 2 - q (2) ** 2 + q (3) ** 2 +C + RETURN + END +C +C QTRFIT +C Find the quaternion, q, [and left rotation matrix, u] that minimizes +C +C |qTXq - Y| ^ 2 [|uX - Y| ^ 2] +C +C This is equivalent to maximizing Re (qTXTqY). +C +C This is equivalent to finding the largest eigenvalue and corresponding +C eigenvector of the matrix +C +C [A2 AUx AUy AUz ] +C [AUx Ux2 UxUy UzUx] +C [AUy UxUy Uy2 UyUz] +C [AUz UzUx UyUz Uz2 ] +C +C where +C +C A2 = Xx Yx + Xy Yy + Xz Yz +C Ux2 = Xx Yx - Xy Yy - Xz Yz +C Uy2 = Xy Yy - Xz Yz - Xx Yx +C Uz2 = Xz Yz - Xx Yx - Xy Yy +C AUx = Xz Yy - Xy Yz +C AUy = Xx Yz - Xz Yx +C AUz = Xy Yx - Xx Yy +C UxUy = Xx Yy + Xy Yx +C UyUz = Xy Yz + Xz Yy +C UzUx = Xz Yx + Xx Yz +C +C The left rotation matrix, u, is obtained from q by +C +C u = qT1q +C +C INPUT +C n - number of points +C x - test vector +C y - reference vector +C w - weight vector +C +C OUTPUT +C q - the best-fit quaternion +C u - the best-fit left rotation matrix +C nr - number of jacobi sweeps required +C + SUBROUTINE qtrfit (n, x, y, w, q, u, nr) + IMPLICIT CHARACTER (A-Z) +C + INTEGER n + DOUBLEPRECISION x (3, n) + DOUBLEPRECISION y (3, n) + DOUBLEPRECISION w (n) + DOUBLEPRECISION q (0 : 3) + DOUBLEPRECISION u (3, 3) + INTEGER nr +C + DOUBLEPRECISION xxyx, xxyy, xxyz + DOUBLEPRECISION xyyx, xyyy, xyyz + DOUBLEPRECISION xzyx, xzyy, xzyz + DOUBLEPRECISION c (0 : 3, 0 : 3), v (0 : 3, 0 : 3) + DOUBLEPRECISION d (0 : 3) + INTEGER i +C +C generate the upper triangle of the quadratic form matrix +C + xxyx = 0.0D0 + xxyy = 0.0D0 + xxyz = 0.0D0 + xyyx = 0.0D0 + xyyy = 0.0D0 + xyyz = 0.0D0 + xzyx = 0.0D0 + xzyy = 0.0D0 + xzyz = 0.0D0 + DO 11000 i = 1, n + xxyx = xxyx + x (1, i) * y (1, i) * w (i) + xxyy = xxyy + x (1, i) * y (2, i) * w (i) + xxyz = xxyz + x (1, i) * y (3, i) * w (i) + xyyx = xyyx + x (2, i) * y (1, i) * w (i) + xyyy = xyyy + x (2, i) * y (2, i) * w (i) + xyyz = xyyz + x (2, i) * y (3, i) * w (i) + xzyx = xzyx + x (3, i) * y (1, i) * w (i) + xzyy = xzyy + x (3, i) * y (2, i) * w (i) + xzyz = xzyz + x (3, i) * y (3, i) * w (i) +11000 CONTINUE +C + c (0, 0) = xxyx + xyyy + xzyz +C + c (0, 1) = xzyy - xyyz + c (1, 1) = xxyx - xyyy - xzyz +C + c (0, 2) = xxyz - xzyx + c (1, 2) = xxyy + xyyx + c (2, 2) = xyyy - xzyz - xxyx +C + c (0, 3) = xyyx - xxyy + c (1, 3) = xzyx + xxyz + c (2, 3) = xyyz + xzyy + c (3, 3) = xzyz - xxyx - xyyy +C +C diagonalize c +C + nr = 16 + CALL jacobi (c, 4, 4, d, v, nr) +C +C extract the desired quaternion +C + q (0) = v (0, 3) + q (1) = v (1, 3) + q (2) = v (2, 3) + q (3) = v (3, 3) +C +C generate the rotation matrix +C + + CALL q2mat (q, u) +C + RETURN + END +C +C RANDOM +C random number generator after Knuth +C + DOUBLEPRECISION FUNCTION random () + IMPLICIT CHARACTER (A-Z) +C + INTEGER ntable + INTEGER im1, im2, im3 + INTEGER ia1, ia2, ia3 + INTEGER ic1, ic2, ic3 + DOUBLEPRECISION rm1, rm2, rm3 + PARAMETER (ntable = 97) + PARAMETER (im1 = 714025, im2 = 214326, im3 = 139968) + PARAMETER (ia1 = 1366, ia2 = 3613, ia3 = 3877) + PARAMETER (ic1 = 150889, ic2 = 45289, ic3 = 29573) + PARAMETER (rm1 = 1.0D0 / im1) + PARAMETER (rm2 = 1.0D0 / im2) + PARAMETER (rm3 = 1.0D0 / im3) +C + INTEGER iseed0, iseed1, iseed2, iseed3 + DOUBLEPRECISION r (ntable) + INTEGER i +C + COMMON /rtable/ iseed0, iseed1, iseed2, iseed3, r + SAVE /rtable/ +C + iseed1 = MOD (ia1 * iseed1 + ic1, im1) + iseed2 = MOD (ia2 * iseed2 + ic2, im2) + iseed3 = MOD (ia3 * iseed3 + ic3, im3) +C + i = 1 + (ntable * iseed3) * rm3 + random = r (i) + r (i) = (iseed1 + iseed2 * rm2) * rm1 +C + RETURN + END + INTEGER FUNCTION ranget () + IMPLICIT CHARACTER (A-Z) +C + INTEGER ntable + INTEGER im1, im2, im3 + INTEGER ia1, ia2, ia3 + INTEGER ic1, ic2, ic3 + DOUBLEPRECISION rm1, rm2, rm3 + PARAMETER (ntable = 97) + PARAMETER (im1 = 714025, im2 = 214326, im3 = 139968) + PARAMETER (ia1 = 1366, ia2 = 3613, ia3 = 3877) + PARAMETER (ic1 = 150889, ic2 = 45289, ic3 = 29573) + PARAMETER (rm1 = 1.0D0 / im1) + PARAMETER (rm2 = 1.0D0 / im2) + PARAMETER (rm3 = 1.0D0 / im3) +C + INTEGER iseed0, iseed1, iseed2, iseed3 + DOUBLEPRECISION r (ntable) +C + COMMON /rtable/ iseed0, iseed1, iseed2, iseed3, r + SAVE /rtable/ +C + ranget = iseed0 +C + RETURN + END +C +C RANINI +C seed the random number generator +C +* SUBROUTINE ranini () +* IMPLICIT CHARACTER (A-Z) +C +* INTEGER bintim (2) +C +* CALL sys$gettim (bintim) +* CALL ranset (IAND (bintim (1), '7FFFFFFF'X)) +C +* RETURN +* END +C +C RANMOL +C generate a random molecule +C + SUBROUTINE ranmol (n, x) + IMPLICIT CHARACTER (A-Z) +C + INTEGER n + DOUBLEPRECISION x (3, n) +C + INTEGER i, j +C + DOUBLEPRECISION random + EXTERNAL random +C +C use nested loops to get same result for scalar/vector +C + DO 10000 j = 1, 3 + DO 10010 i = 1, n + x (j, i) = random () +10010 CONTINUE +10000 CONTINUE +C + RETURN + END +C +C RANROT +C generate a random (almost) rotation matrix +C + SUBROUTINE ranrot (angle, u) + IMPLICIT CHARACTER (A-Z) +C + DOUBLEPRECISION angle + DOUBLEPRECISION u (3, 3) +C + DOUBLEPRECISION a (3) + DOUBLEPRECISION anorm + DOUBLEPRECISION theta + DOUBLEPRECISION pi +C + DOUBLEPRECISION random + EXTERNAL random +C + pi = 4.0D0 * ATAN (1.0D0) +C + a (1) = 0.5D0 - random () + a (2) = 0.5D0 - random () + a (3) = 0.5D0 - random () +C + anorm = SQRT (a (1) ** 2 + a (2) ** 2 + a (3) ** 2) + a (1) = a (1) / anorm + a (2) = a (2) / anorm + a (3) = a (3) / anorM +C + theta = angle * pi * random () +C + CALL genrot (a, COS (theta), SIN (theta), u) +C + RETURN + END + SUBROUTINE ranset (iseed) + IMPLICIT CHARACTER (A-Z) +C + INTEGER ntable + INTEGER im1, im2, im3 + INTEGER ia1, ia2, ia3 + INTEGER ic1, ic2, ic3 + DOUBLEPRECISION rm1, rm2, rm3 + PARAMETER (ntable = 97) + PARAMETER (im1 = 714025, im2 = 214326, im3 = 139968) + PARAMETER (ia1 = 1366, ia2 = 3613, ia3 = 3877) + PARAMETER (ic1 = 150889, ic2 = 45289, ic3 = 29573) + PARAMETER (rm1 = 1.0D0 / im1) + PARAMETER (rm2 = 1.0D0 / im2) + PARAMETER (rm3 = 1.0D0 / im3) +C + INTEGER iseed +C + INTEGER iseed0, iseed1, iseed2, iseed3 + DOUBLEPRECISION r (ntable) + INTEGER i +C + COMMON /rtable/ iseed0, iseed1, iseed2, iseed3, r + SAVE /rtable/ +C + iseed0 = iseed + iseed1 = MOD (iseed0, im1) + iseed2 = MOD (iseed0, im2) + iseed3 = MOD (iseed0, im3) +C + DO 10000 i = 1, ntable + iseed1 = MOD (ia1 * iseed1 + ic1, im1) + iseed2 = MOD (ia2 * iseed2 + ic2, im2) + iseed3 = MOD (ia3 * iseed3 + ic3, im3) + r (i) = (iseed1 + iseed2 * rm2) * rm1 +10000 CONTINUE +C + RETURN + END +C +C ROTMOL +C rotate a molecule +C + SUBROUTINE rotmol (n, x, y, u) + IMPLICIT CHARACTER (A-Z) +C + INTEGER n + DOUBLEPRECISION x (3, n) + DOUBLEPRECISION y (3, n) + DOUBLEPRECISION u (3, 3) +C + DOUBLEPRECISION yx, yy, yz + INTEGER i +C + DO 10000 i = 1, n + yx = u(1, 1) * x(1, i) + u(1, 2) * x(2, i) + u(1, 3) * x(3, i) + yy = u(2, 1) * x(1, i) + u(2, 2) * x(2, i) + u(2, 3) * x(3, i) + yz = u(3, 1) * x(1, i) + u(3, 2) * x(2, i) + u(3, 3) * x(3, i) +C + y (1, i) = yx + y (2, i) = yy + y (3, i) = yz +10000 CONTINUE +C + RETURN + END + + SUBROUTINE LPMN(MM,M,N,X,PM,PD) +C +C ===================================================== +C Purpose: Compute the associated Legendre functions +C Pmn(x) and their derivatives Pmn'(x) +C Input : x --- Argument of Pmn(x) +C m --- Order of Pmn(x), m = 0,1,2,...,n +C n --- Degree of Pmn(x), n = 0,1,2,...,N +C mm --- Physical dimension of PM and PD +C Output: PM(m,n) --- Pmn(x) +C PD(m,n) --- Pmn'(x) +C ===================================================== +C + IMPLICIT DOUBLE PRECISION (P,X) + DIMENSION PM(0:MM,0:MM),PD(0:MM,0:MM) + DO 10 I=0,N + DO 10 J=0,M + PM(J,I)=0.0D0 +10 PD(J,I)=0.0D0 + PM(0,0)=1.0D0 + IF (DABS(X).EQ.1.0D0) THEN + DO 15 I=1,N + PM(0,I)=X**I +15 PD(0,I)=0.5D0*I*(I+1.0D0)*X**(I+1) + DO 20 J=1,N + DO 20 I=1,M + IF (I.EQ.1) THEN + PD(I,J)=1.0D+300 + ELSE IF (I.EQ.2) THEN + PD(I,J)=-0.25D0*(J+2)*(J+1)*J*(J-1)*X**(J+1) + ENDIF +20 CONTINUE + RETURN + ENDIF + LS=1 + IF (DABS(X).GT.1.0D0) LS=-1 + XQ=DSQRT(LS*(1.0D0-X*X)) + XS=LS*(1.0D0-X*X) + DO 30 I=1,M +30 PM(I,I)=-LS*(2.0D0*I-1.0D0)*XQ*PM(I-1,I-1) + DO 35 I=0,M +35 PM(I,I+1)=(2.0D0*I+1.0D0)*X*PM(I,I) + DO 40 I=0,M + DO 40 J=I+2,N + PM(I,J)=((2.0D0*J-1.0D0)*X*PM(I,J-1)- + & (I+J-1.0D0)*PM(I,J-2))/(J-I) +40 CONTINUE + PD(0,0)=0.0D0 + DO 45 J=1,N +45 PD(0,J)=LS*J*(PM(0,J-1)-X*PM(0,J))/XS + DO 50 I=1,M + DO 50 J=I,N + PD(I,J)=LS*I*X*PM(I,J)/XS+(J+I) + & *(J-I+1.0D0)/XQ*PM(I-1,J) +50 CONTINUE + RETURN + END + + diff --git a/co2_co.input b/co2_co.input new file mode 100644 index 0000000..480a654 --- /dev/null +++ b/co2_co.input @@ -0,0 +1,22 @@ + &INPUT + LABEL=' CO-CO2 (CCSD(T) PES) XCS // CS ', + URED=17.1077, ISIGPR=1, ISCRU=0, ISIGU=0, + ISAVEU=0, PRNTLV=4, IRMSET=0, IRXSET=0, + RMIN=5, RMAX=50, STEPS=10, ENERGY=10, + INTFLG=6, DTOL=0.1, OTOL=0.01, + NNRG=1, DNRG=10, + &END + &BASIS + ITYPE=3, + BE(2)=1.93128087, ALPHAE(2)=0.01750441D0, DE(2)=6.12147D-06, + BE(1)=0.390219, ALPHAE(1)=0D0, DE(1)=0d0, + NLEVEL=0, + J1MIN=0, J1MAX=6, J1STEP=2, + J2MIN=0, J2MAX=6, + &END + &POTL + IHOMO=2, IHOMO2=1, + LVRTP=.TRUE., MXLAM=0, NPTS(1)=6, NPTS(2)=6, NPTS(3)=6, L1MAX=5, L2MAX=5, + RM=.529177, EPSIL=1d0, + &END + diff --git a/dblas.f b/dblas.f new file mode 100644 index 0000000..d9669d3 --- /dev/null +++ b/dblas.f @@ -0,0 +1,7152 @@ +C ------------------- BELOW ARE BLAS-1 ROUTINES ------------------ +CUT > IDAMAX.F <<'CUT HERE............' + INTEGER FUNCTION IDAMAX(N,DX,INCX) +C +C FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. +C JACK DONGARRA, LINPACK, 3/11/78. +C MODIFIED 3/93 TO RETURN IF INCX .LE. 0. +C + DOUBLE PRECISION DX(1),DMAX + INTEGER I,INCX,IX,N +C + IDAMAX = 0 + IF( N.LT.1 .OR. INCX.LE.0 ) RETURN + IDAMAX = 1 + IF(N.EQ.1)RETURN + IF(INCX.EQ.1)GO TO 20 +C +C CODE FOR INCREMENT NOT EQUAL TO 1 +C + IX = 1 + DMAX = DABS(DX(1)) + IX = IX + INCX + DO 10 I = 2,N + IF(DABS(DX(IX)).LE.DMAX) GO TO 5 + IDAMAX = I + DMAX = DABS(DX(IX)) + 5 IX = IX + INCX + 10 CONTINUE + RETURN +C +C CODE FOR INCREMENT EQUAL TO 1 +C + 20 DMAX = DABS(DX(1)) + DO 30 I = 2,N + IF(DABS(DX(I)).LE.DMAX) GO TO 30 + IDAMAX = I + DMAX = DABS(DX(I)) + 30 CONTINUE + RETURN + END +CUT HERE............ +CAT > DSWAP.F <<'CUT HERE............' + SUBROUTINE DSWAP (N,DX,INCX,DY,INCY) +C +C INTERCHANGES TWO VECTORS. +C USES UNROLLED LOOPS FOR INCREMENTS EQUAL ONE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + DOUBLE PRECISION DX(1),DY(1),DTEMP + INTEGER I,INCX,INCY,IX,IY,M,MP1,N +C + IF(N.LE.0)RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +C +C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL +C TO 1 +C + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP = DX(IX) + DX(IX) = DY(IY) + DY(IY) = DTEMP + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +C +C CODE FOR BOTH INCREMENTS EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,3) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + 30 CONTINUE + IF( N .LT. 3 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,3 + DTEMP = DX(I) + DX(I) = DY(I) + DY(I) = DTEMP + DTEMP = DX(I + 1) + DX(I + 1) = DY(I + 1) + DY(I + 1) = DTEMP + DTEMP = DX(I + 2) + DX(I + 2) = DY(I + 2) + DY(I + 2) = DTEMP + 50 CONTINUE + RETURN + END +CUT HERE............ +CAT > DSCAL.F <<'CUT HERE............' + SUBROUTINE DSCAL(N,DA,DX,INCX) +C +C SCALES A VECTOR BY A CONSTANT. +C USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE. +C JACK DONGARRA, LINPACK, 3/11/78. +C MODIFIED 3/93 TO RETURN IF INCX .LE. 0. +C + DOUBLE PRECISION DA,DX(1) + INTEGER I,INCX,M,MP1,N,NINCX +C + IF( N.LE.0 .OR. INCX.LE.0 )RETURN + IF(INCX.EQ.1)GO TO 20 +C +C CODE FOR INCREMENT NOT EQUAL TO 1 +C + NINCX = N*INCX + DO 10 I = 1,NINCX,INCX + DX(I) = DA*DX(I) + 10 CONTINUE + RETURN +C +C CODE FOR INCREMENT EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DX(I) = DA*DX(I) + 30 CONTINUE + IF( N .LT. 5 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DX(I) = DA*DX(I) + DX(I + 1) = DA*DX(I + 1) + DX(I + 2) = DA*DX(I + 2) + DX(I + 3) = DA*DX(I + 3) + DX(I + 4) = DA*DX(I + 4) + 50 CONTINUE + RETURN + END +CUT HERE............ +CAT > DROTG.F <<'CUT HERE............' + SUBROUTINE DROTG(DA,DB,C,S) +C +C CONSTRUCT GIVENS PLANE ROTATION. +C JACK DONGARRA, LINPACK, 3/11/78. +C MODIFIED 9/27/86. +C + DOUBLE PRECISION DA,DB,C,S,ROE,SCALE,R,Z +C + ROE = DB + IF( DABS(DA) .GT. DABS(DB) ) ROE = DA + SCALE = DABS(DA) + DABS(DB) + IF( SCALE .NE. 0.0D0 ) GO TO 10 + C = 1.0D0 + S = 0.0D0 + R = 0.0D0 + GO TO 20 + 10 R = SCALE*DSQRT((DA/SCALE)**2 + (DB/SCALE)**2) + R = DSIGN(1.0D0,ROE)*R + C = DA/R + S = DB/R + 20 Z = S + IF( DABS(C) .GT. 0.0D0 .AND. DABS(C) .LE. S ) Z = 1.0D0/C + DA = R + DB = Z + RETURN + END +CUT HERE............ +CAT > DROT.F <<'CUT HERE............' + SUBROUTINE DROT (N,DX,INCX,DY,INCY,C,S) +C +C APPLIES A PLANE ROTATION. +C JACK DONGARRA, LINPACK, 3/11/78. +C + DOUBLE PRECISION DX(1),DY(1),DTEMP,C,S + INTEGER I,INCX,INCY,IX,IY,N +C + IF(N.LE.0)RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +C +C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL +C TO 1 +C + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP = C*DX(IX) + S*DY(IY) + DY(IY) = C*DY(IY) - S*DX(IX) + DX(IX) = DTEMP + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +C +C CODE FOR BOTH INCREMENTS EQUAL TO 1 +C + 20 DO 30 I = 1,N + DTEMP = C*DX(I) + S*DY(I) + DY(I) = C*DY(I) - S*DX(I) + DX(I) = DTEMP + 30 CONTINUE + RETURN + END +CUT HERE............ +CAT > DNRM2.F <<'CUT HERE............' + DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX) + INTEGER I, INCX, IX, J, N, NEXT + DOUBLE PRECISION DX(1), CUTLO, CUTHI, HITEST, SUM, XMAX,ZERO,ONE + DATA ZERO, ONE /0.0D0, 1.0D0/ +C +C EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE +C INCREMENT INCX . +C IF N .LE. 0 RETURN WITH RESULT = 0. +C IF N .GE. 1 THEN INCX MUST BE .GE. 1 +C +C C.L.LAWSON, 1978 JAN 08 +C MODIFIED TO CORRECT FAILURE TO UPDATE IX, 1/25/92. +C MODIFIED 3/93 TO RETURN IF INCX .LE. 0. +C +C FOUR PHASE METHOD USING TWO BUILT-IN CONSTANTS THAT ARE +C HOPEFULLY APPLICABLE TO ALL MACHINES. +C CUTLO = MAXIMUM OF DSQRT(U/EPS) OVER ALL KNOWN MACHINES. +C CUTHI = MINIMUM OF DSQRT(V) OVER ALL KNOWN MACHINES. +C WHERE +C EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1. +C U = SMALLEST POSITIVE NO. (UNDERFLOW LIMIT) +C V = LARGEST NO. (OVERFLOW LIMIT) +C +C BRIEF OUTLINE OF ALGORITHM.. +C +C PHASE 1 SCANS ZERO COMPONENTS. +C MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO +C MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO +C MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M +C WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX. +C +C VALUES FOR CUTLO AND CUTHI.. +C FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER +C DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS.. +C CUTLO, S.P. U/EPS = 2**(-102) FOR HONEYWELL. CLOSE SECONDS ARE +C UNIVAC AND DEC AT 2**(-103) +C THUS CUTLO = 2**(-51) = 4.44089E-16 +C CUTHI, S.P. V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC. +C THUS CUTHI = 2**(63.5) = 1.30438E19 +C CUTLO, D.P. U/EPS = 2**(-67) FOR HONEYWELL AND DEC. +C THUS CUTLO = 2**(-33.5) = 8.23181D-11 +C CUTHI, D.P. SAME AS S.P. CUTHI = 1.30438D19 +C DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / +C DATA CUTLO, CUTHI / 4.441E-16, 1.304E19 / + DATA CUTLO, CUTHI / 8.232D-11, 1.304D19 / +C + IF(N .GT. 0 .AND. INCX.GT.0) GO TO 10 + DNRM2 = ZERO + GO TO 300 +C + 10 ASSIGN 30 TO NEXT + SUM = ZERO + I = 1 + IX = 1 +C BEGIN MAIN LOOP + 20 GO TO NEXT,(30, 50, 70, 110) + 30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 + ASSIGN 50 TO NEXT + XMAX = ZERO +C +C PHASE 1. SUM IS ZERO +C + 50 IF( DX(I) .EQ. ZERO) GO TO 200 + IF( DABS(DX(I)) .GT. CUTLO) GO TO 85 +C +C PREPARE FOR PHASE 2. + ASSIGN 70 TO NEXT + GO TO 105 +C +C PREPARE FOR PHASE 4. +C + 100 CONTINUE + IX = J + ASSIGN 110 TO NEXT + SUM = (SUM / DX(I)) / DX(I) + 105 XMAX = DABS(DX(I)) + GO TO 115 +C +C PHASE 2. SUM IS SMALL. +C SCALE TO AVOID DESTRUCTIVE UNDERFLOW. +C + 70 IF( DABS(DX(I)) .GT. CUTLO ) GO TO 75 +C +C COMMON CODE FOR PHASES 2 AND 4. +C IN PHASE 4 SUM IS LARGE. SCALE TO AVOID OVERFLOW. +C + 110 IF( DABS(DX(I)) .LE. XMAX ) GO TO 115 + SUM = ONE + SUM * (XMAX / DX(I))**2 + XMAX = DABS(DX(I)) + GO TO 200 +C + 115 SUM = SUM + (DX(I)/XMAX)**2 + GO TO 200 +C +C +C PREPARE FOR PHASE 3. +C + 75 SUM = (SUM * XMAX) * XMAX +C +C +C FOR REAL OR D.P. SET HITEST = CUTHI/N +C FOR COMPLEX SET HITEST = CUTHI/(2*N) +C + 85 HITEST = CUTHI/FLOAT( N ) +C +C PHASE 3. SUM IS MID-RANGE. NO SCALING. +C + DO 95 J = IX,N + IF(DABS(DX(I)) .GE. HITEST) GO TO 100 + SUM = SUM + DX(I)**2 + I = I + INCX + 95 CONTINUE + DNRM2 = DSQRT( SUM ) + GO TO 300 +C + 200 CONTINUE + IX = IX + 1 + I = I + INCX + IF( IX .LE. N ) GO TO 20 +C +C END OF MAIN LOOP. +C +C COMPUTE SQUARE ROOT AND ADJUST FOR SCALING. +C + DNRM2 = XMAX * DSQRT(SUM) + 300 CONTINUE + RETURN + END +CUT HERE............ +CAT > DMACH.F <<'CUT HERE............' + DOUBLE PRECISION FUNCTION DMACH(JOB) + INTEGER JOB +C +C SMACH COMPUTES MACHINE PARAMETERS OF FLOATING POINT +C ARITHMETIC FOR USE IN TESTING ONLY. NOT REQUIRED BY +C LINPACK PROPER. +C +C IF TROUBLE WITH AUTOMATIC COMPUTATION OF THESE QUANTITIES, +C THEY CAN BE SET BY DIRECT ASSIGNMENT STATEMENTS. +C ASSUME THE COMPUTER HAS +C +C B = BASE OF ARITHMETIC +C T = NUMBER OF BASE B DIGITS +C L = SMALLEST POSSIBLE EXPONENT +C U = LARGEST POSSIBLE EXPONENT +C +C THEN +C +C EPS = B**(1-T) +C TINY = 100.0*B**(-L+T) +C HUGE = 0.01*B**(U-T) +C +C DMACH SAME AS SMACH EXCEPT T, L, U APPLY TO +C DOUBLE PRECISION. +C +C CMACH SAME AS SMACH EXCEPT IF COMPLEX DIVISION +C IS DONE BY +C +C 1/(X+I*Y) = (X-I*Y)/(X**2+Y**2) +C +C THEN +C +C TINY = SQRT(TINY) +C HUGE = SQRT(HUGE) +C +C +C JOB IS 1, 2 OR 3 FOR EPSILON, TINY AND HUGE, RESPECTIVELY. +C + DOUBLE PRECISION EPS,TINY,HUGE,S +C + EPS = 1.0D0 + 10 EPS = EPS/2.0D0 + S = 1.0D0 + EPS + IF (S .GT. 1.0D0) GO TO 10 + EPS = 2.0D0*EPS +C + S = 1.0D0 + 20 TINY = S + S = S/16.0D0 + IF (S*1.0 .NE. 0.0D0) GO TO 20 + TINY = (TINY/EPS)*100.0 + HUGE = 1.0D0/TINY +C + IF (JOB .EQ. 1) DMACH = EPS + IF (JOB .EQ. 2) DMACH = TINY + IF (JOB .EQ. 3) DMACH = HUGE + RETURN + END +CUT HERE............ +CAT > DDOT.F <<'CUT HERE............' + DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY) +C +C FORMS THE DOT PRODUCT OF TWO VECTORS. +C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + DOUBLE PRECISION DX(1),DY(1),DTEMP + INTEGER I,INCX,INCY,IX,IY,M,MP1,N +C + DDOT = 0.0D0 + DTEMP = 0.0D0 + IF(N.LE.0)RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +C +C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS +C NOT EQUAL TO 1 +C + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DTEMP = DTEMP + DX(IX)*DY(IY) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + DDOT = DTEMP + RETURN +C +C CODE FOR BOTH INCREMENTS EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,5) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP = DTEMP + DX(I)*DY(I) + 30 CONTINUE + IF( N .LT. 5 ) GO TO 60 + 40 MP1 = M + 1 + DO 50 I = MP1,N,5 + DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) + + * DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) + 50 CONTINUE + 60 DDOT = DTEMP + RETURN + END +CUT HERE............ +CAT > DCOPY.F <<'CUT HERE............' + SUBROUTINE DCOPY(N,DX,INCX,DY,INCY) +C +C COPIES A VECTOR, X, TO A VECTOR, Y. +C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + DOUBLE PRECISION DX(1),DY(1) + INTEGER I,INCX,INCY,IX,IY,M,MP1,N +C + IF(N.LE.0)RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +C +C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS +C NOT EQUAL TO 1 +C + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +C +C CODE FOR BOTH INCREMENTS EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,7) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DX(I) + 30 CONTINUE + IF( N .LT. 7 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,7 + DY(I) = DX(I) + DY(I + 1) = DX(I + 1) + DY(I + 2) = DX(I + 2) + DY(I + 3) = DX(I + 3) + DY(I + 4) = DX(I + 4) + DY(I + 5) = DX(I + 5) + DY(I + 6) = DX(I + 6) + 50 CONTINUE + RETURN + END +CUT HERE............ +CAT > DAXPY.F <<'CUT HERE............' + SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) +C +C CONSTANT TIMES A VECTOR PLUS A VECTOR. +C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. +C JACK DONGARRA, LINPACK, 3/11/78. +C + DOUBLE PRECISION DX(1),DY(1),DA + INTEGER I,INCX,INCY,IX,IY,M,MP1,N +C + IF(N.LE.0)RETURN + IF (DA .EQ. 0.0D0) RETURN + IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 +C +C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS +C NOT EQUAL TO 1 +C + IX = 1 + IY = 1 + IF(INCX.LT.0)IX = (-N+1)*INCX + 1 + IF(INCY.LT.0)IY = (-N+1)*INCY + 1 + DO 10 I = 1,N + DY(IY) = DY(IY) + DA*DX(IX) + IX = IX + INCX + IY = IY + INCY + 10 CONTINUE + RETURN +C +C CODE FOR BOTH INCREMENTS EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,4) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DY(I) = DY(I) + DA*DX(I) + 30 CONTINUE + IF( N .LT. 4 ) RETURN + 40 MP1 = M + 1 + DO 50 I = MP1,N,4 + DY(I) = DY(I) + DA*DX(I) + DY(I + 1) = DY(I + 1) + DA*DX(I + 1) + DY(I + 2) = DY(I + 2) + DA*DX(I + 2) + DY(I + 3) = DY(I + 3) + DA*DX(I + 3) + 50 CONTINUE + RETURN + END +CUT HERE............ +CAT > DASUM.F <<'CUT HERE............' + DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX) +C +C TAKES THE SUM OF THE ABSOLUTE VALUES. +C JACK DONGARRA, LINPACK, 3/11/78. +C MODIFIED 3/93 TO RETURN IF INCX .LE. 0. +C + DOUBLE PRECISION DX(1),DTEMP + INTEGER I,INCX,M,MP1,N,NINCX +C + DASUM = 0.0D0 + DTEMP = 0.0D0 + IF( N.LE.0 .OR. INCX.LE.0 )RETURN + IF(INCX.EQ.1)GO TO 20 +C +C CODE FOR INCREMENT NOT EQUAL TO 1 +C + NINCX = N*INCX + DO 10 I = 1,NINCX,INCX + DTEMP = DTEMP + DABS(DX(I)) + 10 CONTINUE + DASUM = DTEMP + RETURN +C +C CODE FOR INCREMENT EQUAL TO 1 +C +C +C CLEAN-UP LOOP +C + 20 M = MOD(N,6) + IF( M .EQ. 0 ) GO TO 40 + DO 30 I = 1,M + DTEMP = DTEMP + DABS(DX(I)) + 30 CONTINUE + IF( N .LT. 6 ) GO TO 60 + 40 MP1 = M + 1 + DO 50 I = MP1,N,6 + DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I + 1)) + DABS(DX(I + 2)) + * + DABS(DX(I + 3)) + DABS(DX(I + 4)) + DABS(DX(I + 5)) + 50 CONTINUE + 60 DASUM = DTEMP + RETURN + END +CUT HERE............ +C --------------- BELOW ARE BLAS-2 ROUTINES ----------------------- +CAT > DSPR2.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) +* .. SCALAR ARGUMENTS .. + DOUBLE PRECISION ALPHA + INTEGER INCX, INCY, N + CHARACTER*1 UPLO +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION AP( * ), X( * ), Y( * ) +* .. +* +* PURPOSE +* ======= +* +* DSPR2 PERFORMS THE SYMMETRIC RANK 2 OPERATION +* +* A := ALPHA*X*Y' + ALPHA*Y*X' + A, +* +* WHERE ALPHA IS A SCALAR, X AND Y ARE N ELEMENT VECTORS AND A IS AN +* N BY N SYMMETRIC MATRIX, SUPPLIED IN PACKED FORM. +* +* PARAMETERS +* ========== +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE UPPER OR LOWER +* TRIANGULAR PART OF THE MATRIX A IS SUPPLIED IN THE PACKED +* ARRAY AP AS FOLLOWS: +* +* UPLO = 'U' OR 'U' THE UPPER TRIANGULAR PART OF A IS +* SUPPLIED IN AP. +* +* UPLO = 'L' OR 'L' THE LOWER TRIANGULAR PART OF A IS +* SUPPLIED IN AP. +* +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE ORDER OF THE MATRIX A. +* N MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* ALPHA - DOUBLE PRECISION. +* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. +* UNCHANGED ON EXIT. +* +* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCX ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE N +* ELEMENT VECTOR X. +* UNCHANGED ON EXIT. +* +* INCX - INTEGER. +* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* X. INCX MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* Y - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCY ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY Y MUST CONTAIN THE N +* ELEMENT VECTOR Y. +* UNCHANGED ON EXIT. +* +* INCY - INTEGER. +* ON ENTRY, INCY SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* Y. INCY MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* AP - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( ( N*( N + 1 ) )/2 ). +* BEFORE ENTRY WITH UPLO = 'U' OR 'U', THE ARRAY AP MUST +* CONTAIN THE UPPER TRIANGULAR PART OF THE SYMMETRIC MATRIX +* PACKED SEQUENTIALLY, COLUMN BY COLUMN, SO THAT AP( 1 ) +* CONTAINS A( 1, 1 ), AP( 2 ) AND AP( 3 ) CONTAIN A( 1, 2 ) +* AND A( 2, 2 ) RESPECTIVELY, AND SO ON. ON EXIT, THE ARRAY +* AP IS OVERWRITTEN BY THE UPPER TRIANGULAR PART OF THE +* UPDATED MATRIX. +* BEFORE ENTRY WITH UPLO = 'L' OR 'L', THE ARRAY AP MUST +* CONTAIN THE LOWER TRIANGULAR PART OF THE SYMMETRIC MATRIX +* PACKED SEQUENTIALLY, COLUMN BY COLUMN, SO THAT AP( 1 ) +* CONTAINS A( 1, 1 ), AP( 2 ) AND AP( 3 ) CONTAIN A( 2, 1 ) +* AND A( 3, 1 ) RESPECTIVELY, AND SO ON. ON EXIT, THE ARRAY +* AP IS OVERWRITTEN BY THE LOWER TRIANGULAR PART OF THE +* UPDATED MATRIX. +* +* +* LEVEL 2 BLAS ROUTINE. +* +* -- WRITTEN ON 22-OCTOBER-1986. +* JACK DONGARRA, ARGONNE NATIONAL LAB. +* JEREMY DU CROZ, NAG CENTRAL OFFICE. +* SVEN HAMMARLING, NAG CENTRAL OFFICE. +* RICHARD HANSON, SANDIA NATIONAL LABS. +* +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. LOCAL SCALARS .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 5 + ELSE IF( INCY.EQ.0 )THEN + INFO = 7 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSPR2 ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) + $ RETURN +* +* SET UP THE START POINTS IN X AND Y IF THE INCREMENTS ARE NOT BOTH +* UNITY. +* + IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF + JX = KX + JY = KY + END IF +* +* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF THE ARRAY AP +* ARE ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH AP. +* + KK = 1 + IF( LSAME( UPLO, 'U' ) )THEN +* +* FORM A WHEN UPPER TRIANGLE IS STORED IN AP. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 20, J = 1, N + IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( J ) + TEMP2 = ALPHA*X( J ) + K = KK + DO 10, I = 1, J + AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 + K = K + 1 + 10 CONTINUE + END IF + KK = KK + J + 20 CONTINUE + ELSE + DO 40, J = 1, N + IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( JY ) + TEMP2 = ALPHA*X( JX ) + IX = KX + IY = KY + DO 30, K = KK, KK + J - 1 + AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + KK = KK + J + 40 CONTINUE + END IF + ELSE +* +* FORM A WHEN LOWER TRIANGLE IS STORED IN AP. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60, J = 1, N + IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( J ) + TEMP2 = ALPHA*X( J ) + K = KK + DO 50, I = J, N + AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 + K = K + 1 + 50 CONTINUE + END IF + KK = KK + N - J + 1 + 60 CONTINUE + ELSE + DO 80, J = 1, N + IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( JY ) + TEMP2 = ALPHA*X( JX ) + IX = JX + IY = JY + DO 70, K = KK, KK + N - J + AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* END OF DSPR2 . +* + END +CUT HERE............ +CAT > DSYR2.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) +* .. SCALAR ARGUMENTS .. + DOUBLE PRECISION ALPHA + INTEGER INCX, INCY, LDA, N + CHARACTER*1 UPLO +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* PURPOSE +* ======= +* +* DSYR2 PERFORMS THE SYMMETRIC RANK 2 OPERATION +* +* A := ALPHA*X*Y' + ALPHA*Y*X' + A, +* +* WHERE ALPHA IS A SCALAR, X AND Y ARE N ELEMENT VECTORS AND A IS AN N +* BY N SYMMETRIC MATRIX. +* +* PARAMETERS +* ========== +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE UPPER OR LOWER +* TRIANGULAR PART OF THE ARRAY A IS TO BE REFERENCED AS +* FOLLOWS: +* +* UPLO = 'U' OR 'U' ONLY THE UPPER TRIANGULAR PART OF A +* IS TO BE REFERENCED. +* +* UPLO = 'L' OR 'L' ONLY THE LOWER TRIANGULAR PART OF A +* IS TO BE REFERENCED. +* +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE ORDER OF THE MATRIX A. +* N MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* ALPHA - DOUBLE PRECISION. +* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. +* UNCHANGED ON EXIT. +* +* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCX ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE N +* ELEMENT VECTOR X. +* UNCHANGED ON EXIT. +* +* INCX - INTEGER. +* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* X. INCX MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* Y - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCY ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY Y MUST CONTAIN THE N +* ELEMENT VECTOR Y. +* UNCHANGED ON EXIT. +* +* INCY - INTEGER. +* ON ENTRY, INCY SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* Y. INCY MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, N ). +* BEFORE ENTRY WITH UPLO = 'U' OR 'U', THE LEADING N BY N +* UPPER TRIANGULAR PART OF THE ARRAY A MUST CONTAIN THE UPPER +* TRIANGULAR PART OF THE SYMMETRIC MATRIX AND THE STRICTLY +* LOWER TRIANGULAR PART OF A IS NOT REFERENCED. ON EXIT, THE +* UPPER TRIANGULAR PART OF THE ARRAY A IS OVERWRITTEN BY THE +* UPPER TRIANGULAR PART OF THE UPDATED MATRIX. +* BEFORE ENTRY WITH UPLO = 'L' OR 'L', THE LEADING N BY N +* LOWER TRIANGULAR PART OF THE ARRAY A MUST CONTAIN THE LOWER +* TRIANGULAR PART OF THE SYMMETRIC MATRIX AND THE STRICTLY +* UPPER TRIANGULAR PART OF A IS NOT REFERENCED. ON EXIT, THE +* LOWER TRIANGULAR PART OF THE ARRAY A IS OVERWRITTEN BY THE +* LOWER TRIANGULAR PART OF THE UPDATED MATRIX. +* +* LDA - INTEGER. +* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDA MUST BE AT LEAST +* MAX( 1, N ). +* UNCHANGED ON EXIT. +* +* +* LEVEL 2 BLAS ROUTINE. +* +* -- WRITTEN ON 22-OCTOBER-1986. +* JACK DONGARRA, ARGONNE NATIONAL LAB. +* JEREMY DU CROZ, NAG CENTRAL OFFICE. +* SVEN HAMMARLING, NAG CENTRAL OFFICE. +* RICHARD HANSON, SANDIA NATIONAL LABS. +* +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. LOCAL SCALARS .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 5 + ELSE IF( INCY.EQ.0 )THEN + INFO = 7 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 9 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYR2 ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) + $ RETURN +* +* SET UP THE START POINTS IN X AND Y IF THE INCREMENTS ARE NOT BOTH +* UNITY. +* + IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF + JX = KX + JY = KY + END IF +* +* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF A ARE +* ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH THE TRIANGULAR PART +* OF A. +* + IF( LSAME( UPLO, 'U' ) )THEN +* +* FORM A WHEN A IS STORED IN THE UPPER TRIANGLE. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 20, J = 1, N + IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( J ) + TEMP2 = ALPHA*X( J ) + DO 10, I = 1, J + A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + DO 40, J = 1, N + IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( JY ) + TEMP2 = ALPHA*X( JX ) + IX = KX + IY = KY + DO 30, I = 1, J + A( I, J ) = A( I, J ) + X( IX )*TEMP1 + $ + Y( IY )*TEMP2 + IX = IX + INCX + IY = IY + INCY + 30 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 40 CONTINUE + END IF + ELSE +* +* FORM A WHEN A IS STORED IN THE LOWER TRIANGLE. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60, J = 1, N + IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( J ) + TEMP2 = ALPHA*X( J ) + DO 50, I = J, N + A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + DO 80, J = 1, N + IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN + TEMP1 = ALPHA*Y( JY ) + TEMP2 = ALPHA*X( JX ) + IX = JX + IY = JY + DO 70, I = J, N + A( I, J ) = A( I, J ) + X( IX )*TEMP1 + $ + Y( IY )*TEMP2 + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + END IF +* + RETURN +* +* END OF DSYR2 . +* + END +CUT HERE............ +CAT > DSPR.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DSPR ( UPLO, N, ALPHA, X, INCX, AP ) +* .. SCALAR ARGUMENTS .. + DOUBLE PRECISION ALPHA + INTEGER INCX, N + CHARACTER*1 UPLO +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION AP( * ), X( * ) +* .. +* +* PURPOSE +* ======= +* +* DSPR PERFORMS THE SYMMETRIC RANK 1 OPERATION +* +* A := ALPHA*X*X' + A, +* +* WHERE ALPHA IS A REAL SCALAR, X IS AN N ELEMENT VECTOR AND A IS AN +* N BY N SYMMETRIC MATRIX, SUPPLIED IN PACKED FORM. +* +* PARAMETERS +* ========== +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE UPPER OR LOWER +* TRIANGULAR PART OF THE MATRIX A IS SUPPLIED IN THE PACKED +* ARRAY AP AS FOLLOWS: +* +* UPLO = 'U' OR 'U' THE UPPER TRIANGULAR PART OF A IS +* SUPPLIED IN AP. +* +* UPLO = 'L' OR 'L' THE LOWER TRIANGULAR PART OF A IS +* SUPPLIED IN AP. +* +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE ORDER OF THE MATRIX A. +* N MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* ALPHA - DOUBLE PRECISION. +* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. +* UNCHANGED ON EXIT. +* +* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCX ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE N +* ELEMENT VECTOR X. +* UNCHANGED ON EXIT. +* +* INCX - INTEGER. +* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* X. INCX MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* AP - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( ( N*( N + 1 ) )/2 ). +* BEFORE ENTRY WITH UPLO = 'U' OR 'U', THE ARRAY AP MUST +* CONTAIN THE UPPER TRIANGULAR PART OF THE SYMMETRIC MATRIX +* PACKED SEQUENTIALLY, COLUMN BY COLUMN, SO THAT AP( 1 ) +* CONTAINS A( 1, 1 ), AP( 2 ) AND AP( 3 ) CONTAIN A( 1, 2 ) +* AND A( 2, 2 ) RESPECTIVELY, AND SO ON. ON EXIT, THE ARRAY +* AP IS OVERWRITTEN BY THE UPPER TRIANGULAR PART OF THE +* UPDATED MATRIX. +* BEFORE ENTRY WITH UPLO = 'L' OR 'L', THE ARRAY AP MUST +* CONTAIN THE LOWER TRIANGULAR PART OF THE SYMMETRIC MATRIX +* PACKED SEQUENTIALLY, COLUMN BY COLUMN, SO THAT AP( 1 ) +* CONTAINS A( 1, 1 ), AP( 2 ) AND AP( 3 ) CONTAIN A( 2, 1 ) +* AND A( 3, 1 ) RESPECTIVELY, AND SO ON. ON EXIT, THE ARRAY +* AP IS OVERWRITTEN BY THE LOWER TRIANGULAR PART OF THE +* UPDATED MATRIX. +* +* +* LEVEL 2 BLAS ROUTINE. +* +* -- WRITTEN ON 22-OCTOBER-1986. +* JACK DONGARRA, ARGONNE NATIONAL LAB. +* JEREMY DU CROZ, NAG CENTRAL OFFICE. +* SVEN HAMMARLING, NAG CENTRAL OFFICE. +* RICHARD HANSON, SANDIA NATIONAL LABS. +* +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. LOCAL SCALARS .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JX, K, KK, KX +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 5 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSPR ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) + $ RETURN +* +* SET THE START POINT IN X IF THE INCREMENT IS NOT UNITY. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF THE ARRAY AP +* ARE ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH AP. +* + KK = 1 + IF( LSAME( UPLO, 'U' ) )THEN +* +* FORM A WHEN UPPER TRIANGLE IS STORED IN AP. +* + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = ALPHA*X( J ) + K = KK + DO 10, I = 1, J + AP( K ) = AP( K ) + X( I )*TEMP + K = K + 1 + 10 CONTINUE + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + IX = KX + DO 30, K = KK, KK + J - 1 + AP( K ) = AP( K ) + X( IX )*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE +* +* FORM A WHEN LOWER TRIANGLE IS STORED IN AP. +* + IF( INCX.EQ.1 )THEN + DO 60, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = ALPHA*X( J ) + K = KK + DO 50, I = J, N + AP( K ) = AP( K ) + X( I )*TEMP + K = K + 1 + 50 CONTINUE + END IF + KK = KK + N - J + 1 + 60 CONTINUE + ELSE + JX = KX + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + IX = JX + DO 70, K = KK, KK + N - J + AP( K ) = AP( K ) + X( IX )*TEMP + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + KK = KK + N - J + 1 + 80 CONTINUE + END IF + END IF +* + RETURN +* +* END OF DSPR . +* + END +CUT HERE............ +CAT > DSYR.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DSYR ( UPLO, N, ALPHA, X, INCX, A, LDA ) +* .. SCALAR ARGUMENTS .. + DOUBLE PRECISION ALPHA + INTEGER INCX, LDA, N + CHARACTER*1 UPLO +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), X( * ) +* .. +* +* PURPOSE +* ======= +* +* DSYR PERFORMS THE SYMMETRIC RANK 1 OPERATION +* +* A := ALPHA*X*X' + A, +* +* WHERE ALPHA IS A REAL SCALAR, X IS AN N ELEMENT VECTOR AND A IS AN +* N BY N SYMMETRIC MATRIX. +* +* PARAMETERS +* ========== +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE UPPER OR LOWER +* TRIANGULAR PART OF THE ARRAY A IS TO BE REFERENCED AS +* FOLLOWS: +* +* UPLO = 'U' OR 'U' ONLY THE UPPER TRIANGULAR PART OF A +* IS TO BE REFERENCED. +* +* UPLO = 'L' OR 'L' ONLY THE LOWER TRIANGULAR PART OF A +* IS TO BE REFERENCED. +* +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE ORDER OF THE MATRIX A. +* N MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* ALPHA - DOUBLE PRECISION. +* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. +* UNCHANGED ON EXIT. +* +* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCX ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE N +* ELEMENT VECTOR X. +* UNCHANGED ON EXIT. +* +* INCX - INTEGER. +* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* X. INCX MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, N ). +* BEFORE ENTRY WITH UPLO = 'U' OR 'U', THE LEADING N BY N +* UPPER TRIANGULAR PART OF THE ARRAY A MUST CONTAIN THE UPPER +* TRIANGULAR PART OF THE SYMMETRIC MATRIX AND THE STRICTLY +* LOWER TRIANGULAR PART OF A IS NOT REFERENCED. ON EXIT, THE +* UPPER TRIANGULAR PART OF THE ARRAY A IS OVERWRITTEN BY THE +* UPPER TRIANGULAR PART OF THE UPDATED MATRIX. +* BEFORE ENTRY WITH UPLO = 'L' OR 'L', THE LEADING N BY N +* LOWER TRIANGULAR PART OF THE ARRAY A MUST CONTAIN THE LOWER +* TRIANGULAR PART OF THE SYMMETRIC MATRIX AND THE STRICTLY +* UPPER TRIANGULAR PART OF A IS NOT REFERENCED. ON EXIT, THE +* LOWER TRIANGULAR PART OF THE ARRAY A IS OVERWRITTEN BY THE +* LOWER TRIANGULAR PART OF THE UPDATED MATRIX. +* +* LDA - INTEGER. +* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDA MUST BE AT LEAST +* MAX( 1, N ). +* UNCHANGED ON EXIT. +* +* +* LEVEL 2 BLAS ROUTINE. +* +* -- WRITTEN ON 22-OCTOBER-1986. +* JACK DONGARRA, ARGONNE NATIONAL LAB. +* JEREMY DU CROZ, NAG CENTRAL OFFICE. +* SVEN HAMMARLING, NAG CENTRAL OFFICE. +* RICHARD HANSON, SANDIA NATIONAL LABS. +* +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. LOCAL SCALARS .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JX, KX +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 5 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 7 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYR ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) + $ RETURN +* +* SET THE START POINT IN X IF THE INCREMENT IS NOT UNITY. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF A ARE +* ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH THE TRIANGULAR PART +* OF A. +* + IF( LSAME( UPLO, 'U' ) )THEN +* +* FORM A WHEN A IS STORED IN UPPER TRIANGLE. +* + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = ALPHA*X( J ) + DO 10, I = 1, J + A( I, J ) = A( I, J ) + X( I )*TEMP + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + IX = KX + DO 30, I = 1, J + A( I, J ) = A( I, J ) + X( IX )*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE +* +* FORM A WHEN A IS STORED IN LOWER TRIANGLE. +* + IF( INCX.EQ.1 )THEN + DO 60, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = ALPHA*X( J ) + DO 50, I = J, N + A( I, J ) = A( I, J ) + X( I )*TEMP + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + IX = JX + DO 70, I = J, N + A( I, J ) = A( I, J ) + X( IX )*TEMP + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF +* + RETURN +* +* END OF DSYR . +* + END +CUT HERE............ +CAT > DGER.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) +* .. SCALAR ARGUMENTS .. + DOUBLE PRECISION ALPHA + INTEGER INCX, INCY, LDA, M, N +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* PURPOSE +* ======= +* +* DGER PERFORMS THE RANK 1 OPERATION +* +* A := ALPHA*X*Y' + A, +* +* WHERE ALPHA IS A SCALAR, X IS AN M ELEMENT VECTOR, Y IS AN N ELEMENT +* VECTOR AND A IS AN M BY N MATRIX. +* +* PARAMETERS +* ========== +* +* M - INTEGER. +* ON ENTRY, M SPECIFIES THE NUMBER OF ROWS OF THE MATRIX A. +* M MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE NUMBER OF COLUMNS OF THE MATRIX A. +* N MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* ALPHA - DOUBLE PRECISION. +* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. +* UNCHANGED ON EXIT. +* +* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( M - 1 )*ABS( INCX ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE M +* ELEMENT VECTOR X. +* UNCHANGED ON EXIT. +* +* INCX - INTEGER. +* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* X. INCX MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* Y - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCY ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY Y MUST CONTAIN THE N +* ELEMENT VECTOR Y. +* UNCHANGED ON EXIT. +* +* INCY - INTEGER. +* ON ENTRY, INCY SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* Y. INCY MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, N ). +* BEFORE ENTRY, THE LEADING M BY N PART OF THE ARRAY A MUST +* CONTAIN THE MATRIX OF COEFFICIENTS. ON EXIT, A IS +* OVERWRITTEN BY THE UPDATED MATRIX. +* +* LDA - INTEGER. +* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDA MUST BE AT LEAST +* MAX( 1, M ). +* UNCHANGED ON EXIT. +* +* +* LEVEL 2 BLAS ROUTINE. +* +* -- WRITTEN ON 22-OCTOBER-1986. +* JACK DONGARRA, ARGONNE NATIONAL LAB. +* JEREMY DU CROZ, NAG CENTRAL OFFICE. +* SVEN HAMMARLING, NAG CENTRAL OFFICE. +* RICHARD HANSON, SANDIA NATIONAL LABS. +* +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. LOCAL SCALARS .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JY, KX +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF ( M.LT.0 )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 5 + ELSE IF( INCY.EQ.0 )THEN + INFO = 7 + ELSE IF( LDA.LT.MAX( 1, M ) )THEN + INFO = 9 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DGER ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) + $ RETURN +* +* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF A ARE +* ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH A. +* + IF( INCY.GT.0 )THEN + JY = 1 + ELSE + JY = 1 - ( N - 1 )*INCY + END IF + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( Y( JY ).NE.ZERO )THEN + TEMP = ALPHA*Y( JY ) + DO 10, I = 1, M + A( I, J ) = A( I, J ) + X( I )*TEMP + 10 CONTINUE + END IF + JY = JY + INCY + 20 CONTINUE + ELSE + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( M - 1 )*INCX + END IF + DO 40, J = 1, N + IF( Y( JY ).NE.ZERO )THEN + TEMP = ALPHA*Y( JY ) + IX = KX + DO 30, I = 1, M + A( I, J ) = A( I, J ) + X( IX )*TEMP + IX = IX + INCX + 30 CONTINUE + END IF + JY = JY + INCY + 40 CONTINUE + END IF +* + RETURN +* +* END OF DGER . +* + END +CUT HERE............ +CAT > DTPSV.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) +* .. SCALAR ARGUMENTS .. + INTEGER INCX, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION AP( * ), X( * ) +* .. +* +* PURPOSE +* ======= +* +* DTPSV SOLVES ONE OF THE SYSTEMS OF EQUATIONS +* +* A*X = B, OR A'*X = B, +* +* WHERE B AND X ARE N ELEMENT VECTORS AND A IS AN N BY N UNIT, OR +* NON-UNIT, UPPER OR LOWER TRIANGULAR MATRIX, SUPPLIED IN PACKED FORM. +* +* NO TEST FOR SINGULARITY OR NEAR-SINGULARITY IS INCLUDED IN THIS +* ROUTINE. SUCH TESTS MUST BE PERFORMED BEFORE CALLING THIS ROUTINE. +* +* PARAMETERS +* ========== +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE MATRIX IS AN UPPER OR +* LOWER TRIANGULAR MATRIX AS FOLLOWS: +* +* UPLO = 'U' OR 'U' A IS AN UPPER TRIANGULAR MATRIX. +* +* UPLO = 'L' OR 'L' A IS A LOWER TRIANGULAR MATRIX. +* +* UNCHANGED ON EXIT. +* +* TRANS - CHARACTER*1. +* ON ENTRY, TRANS SPECIFIES THE EQUATIONS TO BE SOLVED AS +* FOLLOWS: +* +* TRANS = 'N' OR 'N' A*X = B. +* +* TRANS = 'T' OR 'T' A'*X = B. +* +* TRANS = 'C' OR 'C' A'*X = B. +* +* UNCHANGED ON EXIT. +* +* DIAG - CHARACTER*1. +* ON ENTRY, DIAG SPECIFIES WHETHER OR NOT A IS UNIT +* TRIANGULAR AS FOLLOWS: +* +* DIAG = 'U' OR 'U' A IS ASSUMED TO BE UNIT TRIANGULAR. +* +* DIAG = 'N' OR 'N' A IS NOT ASSUMED TO BE UNIT +* TRIANGULAR. +* +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE ORDER OF THE MATRIX A. +* N MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* AP - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( ( N*( N + 1 ) )/2 ). +* BEFORE ENTRY WITH UPLO = 'U' OR 'U', THE ARRAY AP MUST +* CONTAIN THE UPPER TRIANGULAR MATRIX PACKED SEQUENTIALLY, +* COLUMN BY COLUMN, SO THAT AP( 1 ) CONTAINS A( 1, 1 ), +* AP( 2 ) AND AP( 3 ) CONTAIN A( 1, 2 ) AND A( 2, 2 ) +* RESPECTIVELY, AND SO ON. +* BEFORE ENTRY WITH UPLO = 'L' OR 'L', THE ARRAY AP MUST +* CONTAIN THE LOWER TRIANGULAR MATRIX PACKED SEQUENTIALLY, +* COLUMN BY COLUMN, SO THAT AP( 1 ) CONTAINS A( 1, 1 ), +* AP( 2 ) AND AP( 3 ) CONTAIN A( 2, 1 ) AND A( 3, 1 ) +* RESPECTIVELY, AND SO ON. +* NOTE THAT WHEN DIAG = 'U' OR 'U', THE DIAGONAL ELEMENTS OF +* A ARE NOT REFERENCED, BUT ARE ASSUMED TO BE UNITY. +* UNCHANGED ON EXIT. +* +* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCX ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE N +* ELEMENT RIGHT-HAND SIDE VECTOR B. ON EXIT, X IS OVERWRITTEN +* WITH THE SOLUTION VECTOR X. +* +* INCX - INTEGER. +* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* X. INCX MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* +* LEVEL 2 BLAS ROUTINE. +* +* -- WRITTEN ON 22-OCTOBER-1986. +* JACK DONGARRA, ARGONNE NATIONAL LAB. +* JEREMY DU CROZ, NAG CENTRAL OFFICE. +* SVEN HAMMARLING, NAG CENTRAL OFFICE. +* RICHARD HANSON, SANDIA NATIONAL LABS. +* +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. LOCAL SCALARS .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JX, K, KK, KX + LOGICAL NOUNIT +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO , 'U' ).AND. + $ .NOT.LSAME( UPLO , 'L' ) )THEN + INFO = 1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 2 + ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. + $ .NOT.LSAME( DIAG , 'N' ) )THEN + INFO = 3 + ELSE IF( N.LT.0 )THEN + INFO = 4 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DTPSV ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +* +* SET UP THE START POINT IN X IF THE INCREMENT IS NOT UNITY. THIS +* WILL BE ( N - 1 )*INCX TOO SMALL FOR DESCENDING LOOPS. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF AP ARE +* ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH AP. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* FORM X := INV( A )*X. +* + IF( LSAME( UPLO, 'U' ) )THEN + KK = ( N*( N + 1 ) )/2 + IF( INCX.EQ.1 )THEN + DO 20, J = N, 1, -1 + IF( X( J ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( J ) = X( J )/AP( KK ) + TEMP = X( J ) + K = KK - 1 + DO 10, I = J - 1, 1, -1 + X( I ) = X( I ) - TEMP*AP( K ) + K = K - 1 + 10 CONTINUE + END IF + KK = KK - J + 20 CONTINUE + ELSE + JX = KX + ( N - 1 )*INCX + DO 40, J = N, 1, -1 + IF( X( JX ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( JX ) = X( JX )/AP( KK ) + TEMP = X( JX ) + IX = JX + DO 30, K = KK - 1, KK - J + 1, -1 + IX = IX - INCX + X( IX ) = X( IX ) - TEMP*AP( K ) + 30 CONTINUE + END IF + JX = JX - INCX + KK = KK - J + 40 CONTINUE + END IF + ELSE + KK = 1 + IF( INCX.EQ.1 )THEN + DO 60, J = 1, N + IF( X( J ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( J ) = X( J )/AP( KK ) + TEMP = X( J ) + K = KK + 1 + DO 50, I = J + 1, N + X( I ) = X( I ) - TEMP*AP( K ) + K = K + 1 + 50 CONTINUE + END IF + KK = KK + ( N - J + 1 ) + 60 CONTINUE + ELSE + JX = KX + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( JX ) = X( JX )/AP( KK ) + TEMP = X( JX ) + IX = JX + DO 70, K = KK + 1, KK + N - J + IX = IX + INCX + X( IX ) = X( IX ) - TEMP*AP( K ) + 70 CONTINUE + END IF + JX = JX + INCX + KK = KK + ( N - J + 1 ) + 80 CONTINUE + END IF + END IF + ELSE +* +* FORM X := INV( A' )*X. +* + IF( LSAME( UPLO, 'U' ) )THEN + KK = 1 + IF( INCX.EQ.1 )THEN + DO 100, J = 1, N + TEMP = X( J ) + K = KK + DO 90, I = 1, J - 1 + TEMP = TEMP - AP( K )*X( I ) + K = K + 1 + 90 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/AP( KK + J - 1 ) + X( J ) = TEMP + KK = KK + J + 100 CONTINUE + ELSE + JX = KX + DO 120, J = 1, N + TEMP = X( JX ) + IX = KX + DO 110, K = KK, KK + J - 2 + TEMP = TEMP - AP( K )*X( IX ) + IX = IX + INCX + 110 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/AP( KK + J - 1 ) + X( JX ) = TEMP + JX = JX + INCX + KK = KK + J + 120 CONTINUE + END IF + ELSE + KK = ( N*( N + 1 ) )/2 + IF( INCX.EQ.1 )THEN + DO 140, J = N, 1, -1 + TEMP = X( J ) + K = KK + DO 130, I = N, J + 1, -1 + TEMP = TEMP - AP( K )*X( I ) + K = K - 1 + 130 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/AP( KK - N + J ) + X( J ) = TEMP + KK = KK - ( N - J + 1 ) + 140 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 160, J = N, 1, -1 + TEMP = X( JX ) + IX = KX + DO 150, K = KK, KK - ( N - ( J + 1 ) ), -1 + TEMP = TEMP - AP( K )*X( IX ) + IX = IX - INCX + 150 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/AP( KK - N + J ) + X( JX ) = TEMP + JX = JX - INCX + KK = KK - (N - J + 1 ) + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* END OF DTPSV . +* + END +CUT HERE............ +CAT > DTBSV.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) +* .. SCALAR ARGUMENTS .. + INTEGER INCX, K, LDA, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), X( * ) +* .. +* +* PURPOSE +* ======= +* +* DTBSV SOLVES ONE OF THE SYSTEMS OF EQUATIONS +* +* A*X = B, OR A'*X = B, +* +* WHERE B AND X ARE N ELEMENT VECTORS AND A IS AN N BY N UNIT, OR +* NON-UNIT, UPPER OR LOWER TRIANGULAR BAND MATRIX, WITH ( K + 1 ) +* DIAGONALS. +* +* NO TEST FOR SINGULARITY OR NEAR-SINGULARITY IS INCLUDED IN THIS +* ROUTINE. SUCH TESTS MUST BE PERFORMED BEFORE CALLING THIS ROUTINE. +* +* PARAMETERS +* ========== +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE MATRIX IS AN UPPER OR +* LOWER TRIANGULAR MATRIX AS FOLLOWS: +* +* UPLO = 'U' OR 'U' A IS AN UPPER TRIANGULAR MATRIX. +* +* UPLO = 'L' OR 'L' A IS A LOWER TRIANGULAR MATRIX. +* +* UNCHANGED ON EXIT. +* +* TRANS - CHARACTER*1. +* ON ENTRY, TRANS SPECIFIES THE EQUATIONS TO BE SOLVED AS +* FOLLOWS: +* +* TRANS = 'N' OR 'N' A*X = B. +* +* TRANS = 'T' OR 'T' A'*X = B. +* +* TRANS = 'C' OR 'C' A'*X = B. +* +* UNCHANGED ON EXIT. +* +* DIAG - CHARACTER*1. +* ON ENTRY, DIAG SPECIFIES WHETHER OR NOT A IS UNIT +* TRIANGULAR AS FOLLOWS: +* +* DIAG = 'U' OR 'U' A IS ASSUMED TO BE UNIT TRIANGULAR. +* +* DIAG = 'N' OR 'N' A IS NOT ASSUMED TO BE UNIT +* TRIANGULAR. +* +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE ORDER OF THE MATRIX A. +* N MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* K - INTEGER. +* ON ENTRY WITH UPLO = 'U' OR 'U', K SPECIFIES THE NUMBER OF +* SUPER-DIAGONALS OF THE MATRIX A. +* ON ENTRY WITH UPLO = 'L' OR 'L', K SPECIFIES THE NUMBER OF +* SUB-DIAGONALS OF THE MATRIX A. +* K MUST SATISFY 0 .LE. K. +* UNCHANGED ON EXIT. +* +* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, N ). +* BEFORE ENTRY WITH UPLO = 'U' OR 'U', THE LEADING ( K + 1 ) +* BY N PART OF THE ARRAY A MUST CONTAIN THE UPPER TRIANGULAR +* BAND PART OF THE MATRIX OF COEFFICIENTS, SUPPLIED COLUMN BY +* COLUMN, WITH THE LEADING DIAGONAL OF THE MATRIX IN ROW +* ( K + 1 ) OF THE ARRAY, THE FIRST SUPER-DIAGONAL STARTING AT +* POSITION 2 IN ROW K, AND SO ON. THE TOP LEFT K BY K TRIANGLE +* OF THE ARRAY A IS NOT REFERENCED. +* THE FOLLOWING PROGRAM SEGMENT WILL TRANSFER AN UPPER +* TRIANGULAR BAND MATRIX FROM CONVENTIONAL FULL MATRIX STORAGE +* TO BAND STORAGE: +* +* DO 20, J = 1, N +* M = K + 1 - J +* DO 10, I = MAX( 1, J - K ), J +* A( M + I, J ) = MATRIX( I, J ) +* 10 CONTINUE +* 20 CONTINUE +* +* BEFORE ENTRY WITH UPLO = 'L' OR 'L', THE LEADING ( K + 1 ) +* BY N PART OF THE ARRAY A MUST CONTAIN THE LOWER TRIANGULAR +* BAND PART OF THE MATRIX OF COEFFICIENTS, SUPPLIED COLUMN BY +* COLUMN, WITH THE LEADING DIAGONAL OF THE MATRIX IN ROW 1 OF +* THE ARRAY, THE FIRST SUB-DIAGONAL STARTING AT POSITION 1 IN +* ROW 2, AND SO ON. THE BOTTOM RIGHT K BY K TRIANGLE OF THE +* ARRAY A IS NOT REFERENCED. +* THE FOLLOWING PROGRAM SEGMENT WILL TRANSFER A LOWER +* TRIANGULAR BAND MATRIX FROM CONVENTIONAL FULL MATRIX STORAGE +* TO BAND STORAGE: +* +* DO 20, J = 1, N +* M = 1 - J +* DO 10, I = J, MIN( N, J + K ) +* A( M + I, J ) = MATRIX( I, J ) +* 10 CONTINUE +* 20 CONTINUE +* +* NOTE THAT WHEN DIAG = 'U' OR 'U' THE ELEMENTS OF THE ARRAY A +* CORRESPONDING TO THE DIAGONAL ELEMENTS OF THE MATRIX ARE NOT +* REFERENCED, BUT ARE ASSUMED TO BE UNITY. +* UNCHANGED ON EXIT. +* +* LDA - INTEGER. +* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDA MUST BE AT LEAST +* ( K + 1 ). +* UNCHANGED ON EXIT. +* +* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCX ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE N +* ELEMENT RIGHT-HAND SIDE VECTOR B. ON EXIT, X IS OVERWRITTEN +* WITH THE SOLUTION VECTOR X. +* +* INCX - INTEGER. +* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* X. INCX MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* +* LEVEL 2 BLAS ROUTINE. +* +* -- WRITTEN ON 22-OCTOBER-1986. +* JACK DONGARRA, ARGONNE NATIONAL LAB. +* JEREMY DU CROZ, NAG CENTRAL OFFICE. +* SVEN HAMMARLING, NAG CENTRAL OFFICE. +* RICHARD HANSON, SANDIA NATIONAL LABS. +* +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. LOCAL SCALARS .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L + LOGICAL NOUNIT +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO , 'U' ).AND. + $ .NOT.LSAME( UPLO , 'L' ) )THEN + INFO = 1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 2 + ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. + $ .NOT.LSAME( DIAG , 'N' ) )THEN + INFO = 3 + ELSE IF( N.LT.0 )THEN + INFO = 4 + ELSE IF( K.LT.0 )THEN + INFO = 5 + ELSE IF( LDA.LT.( K + 1 ) )THEN + INFO = 7 + ELSE IF( INCX.EQ.0 )THEN + INFO = 9 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DTBSV ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +* +* SET UP THE START POINT IN X IF THE INCREMENT IS NOT UNITY. THIS +* WILL BE ( N - 1 )*INCX TOO SMALL FOR DESCENDING LOOPS. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF A ARE +* ACCESSED BY SEQUENTIALLY WITH ONE PASS THROUGH A. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* FORM X := INV( A )*X. +* + IF( LSAME( UPLO, 'U' ) )THEN + KPLUS1 = K + 1 + IF( INCX.EQ.1 )THEN + DO 20, J = N, 1, -1 + IF( X( J ).NE.ZERO )THEN + L = KPLUS1 - J + IF( NOUNIT ) + $ X( J ) = X( J )/A( KPLUS1, J ) + TEMP = X( J ) + DO 10, I = J - 1, MAX( 1, J - K ), -1 + X( I ) = X( I ) - TEMP*A( L + I, J ) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 40, J = N, 1, -1 + KX = KX - INCX + IF( X( JX ).NE.ZERO )THEN + IX = KX + L = KPLUS1 - J + IF( NOUNIT ) + $ X( JX ) = X( JX )/A( KPLUS1, J ) + TEMP = X( JX ) + DO 30, I = J - 1, MAX( 1, J - K ), -1 + X( IX ) = X( IX ) - TEMP*A( L + I, J ) + IX = IX - INCX + 30 CONTINUE + END IF + JX = JX - INCX + 40 CONTINUE + END IF + ELSE + IF( INCX.EQ.1 )THEN + DO 60, J = 1, N + IF( X( J ).NE.ZERO )THEN + L = 1 - J + IF( NOUNIT ) + $ X( J ) = X( J )/A( 1, J ) + TEMP = X( J ) + DO 50, I = J + 1, MIN( N, J + K ) + X( I ) = X( I ) - TEMP*A( L + I, J ) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80, J = 1, N + KX = KX + INCX + IF( X( JX ).NE.ZERO )THEN + IX = KX + L = 1 - J + IF( NOUNIT ) + $ X( JX ) = X( JX )/A( 1, J ) + TEMP = X( JX ) + DO 70, I = J + 1, MIN( N, J + K ) + X( IX ) = X( IX ) - TEMP*A( L + I, J ) + IX = IX + INCX + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* FORM X := INV( A')*X. +* + IF( LSAME( UPLO, 'U' ) )THEN + KPLUS1 = K + 1 + IF( INCX.EQ.1 )THEN + DO 100, J = 1, N + TEMP = X( J ) + L = KPLUS1 - J + DO 90, I = MAX( 1, J - K ), J - 1 + TEMP = TEMP - A( L + I, J )*X( I ) + 90 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( KPLUS1, J ) + X( J ) = TEMP + 100 CONTINUE + ELSE + JX = KX + DO 120, J = 1, N + TEMP = X( JX ) + IX = KX + L = KPLUS1 - J + DO 110, I = MAX( 1, J - K ), J - 1 + TEMP = TEMP - A( L + I, J )*X( IX ) + IX = IX + INCX + 110 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( KPLUS1, J ) + X( JX ) = TEMP + JX = JX + INCX + IF( J.GT.K ) + $ KX = KX + INCX + 120 CONTINUE + END IF + ELSE + IF( INCX.EQ.1 )THEN + DO 140, J = N, 1, -1 + TEMP = X( J ) + L = 1 - J + DO 130, I = MIN( N, J + K ), J + 1, -1 + TEMP = TEMP - A( L + I, J )*X( I ) + 130 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( 1, J ) + X( J ) = TEMP + 140 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 160, J = N, 1, -1 + TEMP = X( JX ) + IX = KX + L = 1 - J + DO 150, I = MIN( N, J + K ), J + 1, -1 + TEMP = TEMP - A( L + I, J )*X( IX ) + IX = IX - INCX + 150 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( 1, J ) + X( JX ) = TEMP + JX = JX - INCX + IF( ( N - J ).GE.K ) + $ KX = KX - INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* END OF DTBSV . +* + END +CUT HERE............ +CAT > DTRSV.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) +* .. SCALAR ARGUMENTS .. + INTEGER INCX, LDA, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), X( * ) +* .. +* +* PURPOSE +* ======= +* +* DTRSV SOLVES ONE OF THE SYSTEMS OF EQUATIONS +* +* A*X = B, OR A'*X = B, +* +* WHERE B AND X ARE N ELEMENT VECTORS AND A IS AN N BY N UNIT, OR +* NON-UNIT, UPPER OR LOWER TRIANGULAR MATRIX. +* +* NO TEST FOR SINGULARITY OR NEAR-SINGULARITY IS INCLUDED IN THIS +* ROUTINE. SUCH TESTS MUST BE PERFORMED BEFORE CALLING THIS ROUTINE. +* +* PARAMETERS +* ========== +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE MATRIX IS AN UPPER OR +* LOWER TRIANGULAR MATRIX AS FOLLOWS: +* +* UPLO = 'U' OR 'U' A IS AN UPPER TRIANGULAR MATRIX. +* +* UPLO = 'L' OR 'L' A IS A LOWER TRIANGULAR MATRIX. +* +* UNCHANGED ON EXIT. +* +* TRANS - CHARACTER*1. +* ON ENTRY, TRANS SPECIFIES THE EQUATIONS TO BE SOLVED AS +* FOLLOWS: +* +* TRANS = 'N' OR 'N' A*X = B. +* +* TRANS = 'T' OR 'T' A'*X = B. +* +* TRANS = 'C' OR 'C' A'*X = B. +* +* UNCHANGED ON EXIT. +* +* DIAG - CHARACTER*1. +* ON ENTRY, DIAG SPECIFIES WHETHER OR NOT A IS UNIT +* TRIANGULAR AS FOLLOWS: +* +* DIAG = 'U' OR 'U' A IS ASSUMED TO BE UNIT TRIANGULAR. +* +* DIAG = 'N' OR 'N' A IS NOT ASSUMED TO BE UNIT +* TRIANGULAR. +* +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE ORDER OF THE MATRIX A. +* N MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, N ). +* BEFORE ENTRY WITH UPLO = 'U' OR 'U', THE LEADING N BY N +* UPPER TRIANGULAR PART OF THE ARRAY A MUST CONTAIN THE UPPER +* TRIANGULAR MATRIX AND THE STRICTLY LOWER TRIANGULAR PART OF +* A IS NOT REFERENCED. +* BEFORE ENTRY WITH UPLO = 'L' OR 'L', THE LEADING N BY N +* LOWER TRIANGULAR PART OF THE ARRAY A MUST CONTAIN THE LOWER +* TRIANGULAR MATRIX AND THE STRICTLY UPPER TRIANGULAR PART OF +* A IS NOT REFERENCED. +* NOTE THAT WHEN DIAG = 'U' OR 'U', THE DIAGONAL ELEMENTS OF +* A ARE NOT REFERENCED EITHER, BUT ARE ASSUMED TO BE UNITY. +* UNCHANGED ON EXIT. +* +* LDA - INTEGER. +* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDA MUST BE AT LEAST +* MAX( 1, N ). +* UNCHANGED ON EXIT. +* +* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCX ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE N +* ELEMENT RIGHT-HAND SIDE VECTOR B. ON EXIT, X IS OVERWRITTEN +* WITH THE SOLUTION VECTOR X. +* +* INCX - INTEGER. +* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* X. INCX MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* +* LEVEL 2 BLAS ROUTINE. +* +* -- WRITTEN ON 22-OCTOBER-1986. +* JACK DONGARRA, ARGONNE NATIONAL LAB. +* JEREMY DU CROZ, NAG CENTRAL OFFICE. +* SVEN HAMMARLING, NAG CENTRAL OFFICE. +* RICHARD HANSON, SANDIA NATIONAL LABS. +* +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. LOCAL SCALARS .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JX, KX + LOGICAL NOUNIT +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO , 'U' ).AND. + $ .NOT.LSAME( UPLO , 'L' ) )THEN + INFO = 1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 2 + ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. + $ .NOT.LSAME( DIAG , 'N' ) )THEN + INFO = 3 + ELSE IF( N.LT.0 )THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DTRSV ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +* +* SET UP THE START POINT IN X IF THE INCREMENT IS NOT UNITY. THIS +* WILL BE ( N - 1 )*INCX TOO SMALL FOR DESCENDING LOOPS. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF A ARE +* ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH A. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* FORM X := INV( A )*X. +* + IF( LSAME( UPLO, 'U' ) )THEN + IF( INCX.EQ.1 )THEN + DO 20, J = N, 1, -1 + IF( X( J ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( J ) = X( J )/A( J, J ) + TEMP = X( J ) + DO 10, I = J - 1, 1, -1 + X( I ) = X( I ) - TEMP*A( I, J ) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE + JX = KX + ( N - 1 )*INCX + DO 40, J = N, 1, -1 + IF( X( JX ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( JX ) = X( JX )/A( J, J ) + TEMP = X( JX ) + IX = JX + DO 30, I = J - 1, 1, -1 + IX = IX - INCX + X( IX ) = X( IX ) - TEMP*A( I, J ) + 30 CONTINUE + END IF + JX = JX - INCX + 40 CONTINUE + END IF + ELSE + IF( INCX.EQ.1 )THEN + DO 60, J = 1, N + IF( X( J ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( J ) = X( J )/A( J, J ) + TEMP = X( J ) + DO 50, I = J + 1, N + X( I ) = X( I ) - TEMP*A( I, J ) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE + JX = KX + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + IF( NOUNIT ) + $ X( JX ) = X( JX )/A( J, J ) + TEMP = X( JX ) + IX = JX + DO 70, I = J + 1, N + IX = IX + INCX + X( IX ) = X( IX ) - TEMP*A( I, J ) + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* FORM X := INV( A' )*X. +* + IF( LSAME( UPLO, 'U' ) )THEN + IF( INCX.EQ.1 )THEN + DO 100, J = 1, N + TEMP = X( J ) + DO 90, I = 1, J - 1 + TEMP = TEMP - A( I, J )*X( I ) + 90 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( J, J ) + X( J ) = TEMP + 100 CONTINUE + ELSE + JX = KX + DO 120, J = 1, N + TEMP = X( JX ) + IX = KX + DO 110, I = 1, J - 1 + TEMP = TEMP - A( I, J )*X( IX ) + IX = IX + INCX + 110 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( J, J ) + X( JX ) = TEMP + JX = JX + INCX + 120 CONTINUE + END IF + ELSE + IF( INCX.EQ.1 )THEN + DO 140, J = N, 1, -1 + TEMP = X( J ) + DO 130, I = N, J + 1, -1 + TEMP = TEMP - A( I, J )*X( I ) + 130 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( J, J ) + X( J ) = TEMP + 140 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 160, J = N, 1, -1 + TEMP = X( JX ) + IX = KX + DO 150, I = N, J + 1, -1 + TEMP = TEMP - A( I, J )*X( IX ) + IX = IX - INCX + 150 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( J, J ) + X( JX ) = TEMP + JX = JX - INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* END OF DTRSV . +* + END +CUT HERE............ +CAT > DTPMV.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) +* .. SCALAR ARGUMENTS .. + INTEGER INCX, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION AP( * ), X( * ) +* .. +* +* PURPOSE +* ======= +* +* DTPMV PERFORMS ONE OF THE MATRIX-VECTOR OPERATIONS +* +* X := A*X, OR X := A'*X, +* +* WHERE X IS AN N ELEMENT VECTOR AND A IS AN N BY N UNIT, OR NON-UNIT, +* UPPER OR LOWER TRIANGULAR MATRIX, SUPPLIED IN PACKED FORM. +* +* PARAMETERS +* ========== +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE MATRIX IS AN UPPER OR +* LOWER TRIANGULAR MATRIX AS FOLLOWS: +* +* UPLO = 'U' OR 'U' A IS AN UPPER TRIANGULAR MATRIX. +* +* UPLO = 'L' OR 'L' A IS A LOWER TRIANGULAR MATRIX. +* +* UNCHANGED ON EXIT. +* +* TRANS - CHARACTER*1. +* ON ENTRY, TRANS SPECIFIES THE OPERATION TO BE PERFORMED AS +* FOLLOWS: +* +* TRANS = 'N' OR 'N' X := A*X. +* +* TRANS = 'T' OR 'T' X := A'*X. +* +* TRANS = 'C' OR 'C' X := A'*X. +* +* UNCHANGED ON EXIT. +* +* DIAG - CHARACTER*1. +* ON ENTRY, DIAG SPECIFIES WHETHER OR NOT A IS UNIT +* TRIANGULAR AS FOLLOWS: +* +* DIAG = 'U' OR 'U' A IS ASSUMED TO BE UNIT TRIANGULAR. +* +* DIAG = 'N' OR 'N' A IS NOT ASSUMED TO BE UNIT +* TRIANGULAR. +* +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE ORDER OF THE MATRIX A. +* N MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* AP - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( ( N*( N + 1 ) )/2 ). +* BEFORE ENTRY WITH UPLO = 'U' OR 'U', THE ARRAY AP MUST +* CONTAIN THE UPPER TRIANGULAR MATRIX PACKED SEQUENTIALLY, +* COLUMN BY COLUMN, SO THAT AP( 1 ) CONTAINS A( 1, 1 ), +* AP( 2 ) AND AP( 3 ) CONTAIN A( 1, 2 ) AND A( 2, 2 ) +* RESPECTIVELY, AND SO ON. +* BEFORE ENTRY WITH UPLO = 'L' OR 'L', THE ARRAY AP MUST +* CONTAIN THE LOWER TRIANGULAR MATRIX PACKED SEQUENTIALLY, +* COLUMN BY COLUMN, SO THAT AP( 1 ) CONTAINS A( 1, 1 ), +* AP( 2 ) AND AP( 3 ) CONTAIN A( 2, 1 ) AND A( 3, 1 ) +* RESPECTIVELY, AND SO ON. +* NOTE THAT WHEN DIAG = 'U' OR 'U', THE DIAGONAL ELEMENTS OF +* A ARE NOT REFERENCED, BUT ARE ASSUMED TO BE UNITY. +* UNCHANGED ON EXIT. +* +* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCX ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE N +* ELEMENT VECTOR X. ON EXIT, X IS OVERWRITTEN WITH THE +* TRANFORMED VECTOR X. +* +* INCX - INTEGER. +* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* X. INCX MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* +* LEVEL 2 BLAS ROUTINE. +* +* -- WRITTEN ON 22-OCTOBER-1986. +* JACK DONGARRA, ARGONNE NATIONAL LAB. +* JEREMY DU CROZ, NAG CENTRAL OFFICE. +* SVEN HAMMARLING, NAG CENTRAL OFFICE. +* RICHARD HANSON, SANDIA NATIONAL LABS. +* +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. LOCAL SCALARS .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JX, K, KK, KX + LOGICAL NOUNIT +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO , 'U' ).AND. + $ .NOT.LSAME( UPLO , 'L' ) )THEN + INFO = 1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 2 + ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. + $ .NOT.LSAME( DIAG , 'N' ) )THEN + INFO = 3 + ELSE IF( N.LT.0 )THEN + INFO = 4 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DTPMV ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +* +* SET UP THE START POINT IN X IF THE INCREMENT IS NOT UNITY. THIS +* WILL BE ( N - 1 )*INCX TOO SMALL FOR DESCENDING LOOPS. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF AP ARE +* ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH AP. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* FORM X:= A*X. +* + IF( LSAME( UPLO, 'U' ) )THEN + KK =1 + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + K = KK + DO 10, I = 1, J - 1 + X( I ) = X( I ) + TEMP*AP( K ) + K = K + 1 + 10 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*AP( KK + J - 1 ) + END IF + KK = KK + J + 20 CONTINUE + ELSE + JX = KX + DO 40, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + DO 30, K = KK, KK + J - 2 + X( IX ) = X( IX ) + TEMP*AP( K ) + IX = IX + INCX + 30 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*AP( KK + J - 1 ) + END IF + JX = JX + INCX + KK = KK + J + 40 CONTINUE + END IF + ELSE + KK = ( N*( N + 1 ) )/2 + IF( INCX.EQ.1 )THEN + DO 60, J = N, 1, -1 + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + K = KK + DO 50, I = N, J + 1, -1 + X( I ) = X( I ) + TEMP*AP( K ) + K = K - 1 + 50 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*AP( KK - N + J ) + END IF + KK = KK - ( N - J + 1 ) + 60 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 80, J = N, 1, -1 + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1 + X( IX ) = X( IX ) + TEMP*AP( K ) + IX = IX - INCX + 70 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*AP( KK - N + J ) + END IF + JX = JX - INCX + KK = KK - ( N - J + 1 ) + 80 CONTINUE + END IF + END IF + ELSE +* +* FORM X := A'*X. +* + IF( LSAME( UPLO, 'U' ) )THEN + KK = ( N*( N + 1 ) )/2 + IF( INCX.EQ.1 )THEN + DO 100, J = N, 1, -1 + TEMP = X( J ) + IF( NOUNIT ) + $ TEMP = TEMP*AP( KK ) + K = KK - 1 + DO 90, I = J - 1, 1, -1 + TEMP = TEMP + AP( K )*X( I ) + K = K - 1 + 90 CONTINUE + X( J ) = TEMP + KK = KK - J + 100 CONTINUE + ELSE + JX = KX + ( N - 1 )*INCX + DO 120, J = N, 1, -1 + TEMP = X( JX ) + IX = JX + IF( NOUNIT ) + $ TEMP = TEMP*AP( KK ) + DO 110, K = KK - 1, KK - J + 1, -1 + IX = IX - INCX + TEMP = TEMP + AP( K )*X( IX ) + 110 CONTINUE + X( JX ) = TEMP + JX = JX - INCX + KK = KK - J + 120 CONTINUE + END IF + ELSE + KK = 1 + IF( INCX.EQ.1 )THEN + DO 140, J = 1, N + TEMP = X( J ) + IF( NOUNIT ) + $ TEMP = TEMP*AP( KK ) + K = KK + 1 + DO 130, I = J + 1, N + TEMP = TEMP + AP( K )*X( I ) + K = K + 1 + 130 CONTINUE + X( J ) = TEMP + KK = KK + ( N - J + 1 ) + 140 CONTINUE + ELSE + JX = KX + DO 160, J = 1, N + TEMP = X( JX ) + IX = JX + IF( NOUNIT ) + $ TEMP = TEMP*AP( KK ) + DO 150, K = KK + 1, KK + N - J + IX = IX + INCX + TEMP = TEMP + AP( K )*X( IX ) + 150 CONTINUE + X( JX ) = TEMP + JX = JX + INCX + KK = KK + ( N - J + 1 ) + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* END OF DTPMV . +* + END +CUT HERE............ +CAT > DTBMV.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DTBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) +* .. SCALAR ARGUMENTS .. + INTEGER INCX, K, LDA, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), X( * ) +* .. +* +* PURPOSE +* ======= +* +* DTBMV PERFORMS ONE OF THE MATRIX-VECTOR OPERATIONS +* +* X := A*X, OR X := A'*X, +* +* WHERE X IS AN N ELEMENT VECTOR AND A IS AN N BY N UNIT, OR NON-UNIT, +* UPPER OR LOWER TRIANGULAR BAND MATRIX, WITH ( K + 1 ) DIAGONALS. +* +* PARAMETERS +* ========== +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE MATRIX IS AN UPPER OR +* LOWER TRIANGULAR MATRIX AS FOLLOWS: +* +* UPLO = 'U' OR 'U' A IS AN UPPER TRIANGULAR MATRIX. +* +* UPLO = 'L' OR 'L' A IS A LOWER TRIANGULAR MATRIX. +* +* UNCHANGED ON EXIT. +* +* TRANS - CHARACTER*1. +* ON ENTRY, TRANS SPECIFIES THE OPERATION TO BE PERFORMED AS +* FOLLOWS: +* +* TRANS = 'N' OR 'N' X := A*X. +* +* TRANS = 'T' OR 'T' X := A'*X. +* +* TRANS = 'C' OR 'C' X := A'*X. +* +* UNCHANGED ON EXIT. +* +* DIAG - CHARACTER*1. +* ON ENTRY, DIAG SPECIFIES WHETHER OR NOT A IS UNIT +* TRIANGULAR AS FOLLOWS: +* +* DIAG = 'U' OR 'U' A IS ASSUMED TO BE UNIT TRIANGULAR. +* +* DIAG = 'N' OR 'N' A IS NOT ASSUMED TO BE UNIT +* TRIANGULAR. +* +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE ORDER OF THE MATRIX A. +* N MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* K - INTEGER. +* ON ENTRY WITH UPLO = 'U' OR 'U', K SPECIFIES THE NUMBER OF +* SUPER-DIAGONALS OF THE MATRIX A. +* ON ENTRY WITH UPLO = 'L' OR 'L', K SPECIFIES THE NUMBER OF +* SUB-DIAGONALS OF THE MATRIX A. +* K MUST SATISFY 0 .LE. K. +* UNCHANGED ON EXIT. +* +* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, N ). +* BEFORE ENTRY WITH UPLO = 'U' OR 'U', THE LEADING ( K + 1 ) +* BY N PART OF THE ARRAY A MUST CONTAIN THE UPPER TRIANGULAR +* BAND PART OF THE MATRIX OF COEFFICIENTS, SUPPLIED COLUMN BY +* COLUMN, WITH THE LEADING DIAGONAL OF THE MATRIX IN ROW +* ( K + 1 ) OF THE ARRAY, THE FIRST SUPER-DIAGONAL STARTING AT +* POSITION 2 IN ROW K, AND SO ON. THE TOP LEFT K BY K TRIANGLE +* OF THE ARRAY A IS NOT REFERENCED. +* THE FOLLOWING PROGRAM SEGMENT WILL TRANSFER AN UPPER +* TRIANGULAR BAND MATRIX FROM CONVENTIONAL FULL MATRIX STORAGE +* TO BAND STORAGE: +* +* DO 20, J = 1, N +* M = K + 1 - J +* DO 10, I = MAX( 1, J - K ), J +* A( M + I, J ) = MATRIX( I, J ) +* 10 CONTINUE +* 20 CONTINUE +* +* BEFORE ENTRY WITH UPLO = 'L' OR 'L', THE LEADING ( K + 1 ) +* BY N PART OF THE ARRAY A MUST CONTAIN THE LOWER TRIANGULAR +* BAND PART OF THE MATRIX OF COEFFICIENTS, SUPPLIED COLUMN BY +* COLUMN, WITH THE LEADING DIAGONAL OF THE MATRIX IN ROW 1 OF +* THE ARRAY, THE FIRST SUB-DIAGONAL STARTING AT POSITION 1 IN +* ROW 2, AND SO ON. THE BOTTOM RIGHT K BY K TRIANGLE OF THE +* ARRAY A IS NOT REFERENCED. +* THE FOLLOWING PROGRAM SEGMENT WILL TRANSFER A LOWER +* TRIANGULAR BAND MATRIX FROM CONVENTIONAL FULL MATRIX STORAGE +* TO BAND STORAGE: +* +* DO 20, J = 1, N +* M = 1 - J +* DO 10, I = J, MIN( N, J + K ) +* A( M + I, J ) = MATRIX( I, J ) +* 10 CONTINUE +* 20 CONTINUE +* +* NOTE THAT WHEN DIAG = 'U' OR 'U' THE ELEMENTS OF THE ARRAY A +* CORRESPONDING TO THE DIAGONAL ELEMENTS OF THE MATRIX ARE NOT +* REFERENCED, BUT ARE ASSUMED TO BE UNITY. +* UNCHANGED ON EXIT. +* +* LDA - INTEGER. +* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDA MUST BE AT LEAST +* ( K + 1 ). +* UNCHANGED ON EXIT. +* +* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCX ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE N +* ELEMENT VECTOR X. ON EXIT, X IS OVERWRITTEN WITH THE +* TRANFORMED VECTOR X. +* +* INCX - INTEGER. +* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* X. INCX MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* +* LEVEL 2 BLAS ROUTINE. +* +* -- WRITTEN ON 22-OCTOBER-1986. +* JACK DONGARRA, ARGONNE NATIONAL LAB. +* JEREMY DU CROZ, NAG CENTRAL OFFICE. +* SVEN HAMMARLING, NAG CENTRAL OFFICE. +* RICHARD HANSON, SANDIA NATIONAL LABS. +* +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. LOCAL SCALARS .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L + LOGICAL NOUNIT +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO , 'U' ).AND. + $ .NOT.LSAME( UPLO , 'L' ) )THEN + INFO = 1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 2 + ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. + $ .NOT.LSAME( DIAG , 'N' ) )THEN + INFO = 3 + ELSE IF( N.LT.0 )THEN + INFO = 4 + ELSE IF( K.LT.0 )THEN + INFO = 5 + ELSE IF( LDA.LT.( K + 1 ) )THEN + INFO = 7 + ELSE IF( INCX.EQ.0 )THEN + INFO = 9 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DTBMV ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +* +* SET UP THE START POINT IN X IF THE INCREMENT IS NOT UNITY. THIS +* WILL BE ( N - 1 )*INCX TOO SMALL FOR DESCENDING LOOPS. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF A ARE +* ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH A. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* FORM X := A*X. +* + IF( LSAME( UPLO, 'U' ) )THEN + KPLUS1 = K + 1 + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + L = KPLUS1 - J + DO 10, I = MAX( 1, J - K ), J - 1 + X( I ) = X( I ) + TEMP*A( L + I, J ) + 10 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*A( KPLUS1, J ) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + L = KPLUS1 - J + DO 30, I = MAX( 1, J - K ), J - 1 + X( IX ) = X( IX ) + TEMP*A( L + I, J ) + IX = IX + INCX + 30 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*A( KPLUS1, J ) + END IF + JX = JX + INCX + IF( J.GT.K ) + $ KX = KX + INCX + 40 CONTINUE + END IF + ELSE + IF( INCX.EQ.1 )THEN + DO 60, J = N, 1, -1 + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + L = 1 - J + DO 50, I = MIN( N, J + K ), J + 1, -1 + X( I ) = X( I ) + TEMP*A( L + I, J ) + 50 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*A( 1, J ) + END IF + 60 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 80, J = N, 1, -1 + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + L = 1 - J + DO 70, I = MIN( N, J + K ), J + 1, -1 + X( IX ) = X( IX ) + TEMP*A( L + I, J ) + IX = IX - INCX + 70 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*A( 1, J ) + END IF + JX = JX - INCX + IF( ( N - J ).GE.K ) + $ KX = KX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* FORM X := A'*X. +* + IF( LSAME( UPLO, 'U' ) )THEN + KPLUS1 = K + 1 + IF( INCX.EQ.1 )THEN + DO 100, J = N, 1, -1 + TEMP = X( J ) + L = KPLUS1 - J + IF( NOUNIT ) + $ TEMP = TEMP*A( KPLUS1, J ) + DO 90, I = J - 1, MAX( 1, J - K ), -1 + TEMP = TEMP + A( L + I, J )*X( I ) + 90 CONTINUE + X( J ) = TEMP + 100 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 120, J = N, 1, -1 + TEMP = X( JX ) + KX = KX - INCX + IX = KX + L = KPLUS1 - J + IF( NOUNIT ) + $ TEMP = TEMP*A( KPLUS1, J ) + DO 110, I = J - 1, MAX( 1, J - K ), -1 + TEMP = TEMP + A( L + I, J )*X( IX ) + IX = IX - INCX + 110 CONTINUE + X( JX ) = TEMP + JX = JX - INCX + 120 CONTINUE + END IF + ELSE + IF( INCX.EQ.1 )THEN + DO 140, J = 1, N + TEMP = X( J ) + L = 1 - J + IF( NOUNIT ) + $ TEMP = TEMP*A( 1, J ) + DO 130, I = J + 1, MIN( N, J + K ) + TEMP = TEMP + A( L + I, J )*X( I ) + 130 CONTINUE + X( J ) = TEMP + 140 CONTINUE + ELSE + JX = KX + DO 160, J = 1, N + TEMP = X( JX ) + KX = KX + INCX + IX = KX + L = 1 - J + IF( NOUNIT ) + $ TEMP = TEMP*A( 1, J ) + DO 150, I = J + 1, MIN( N, J + K ) + TEMP = TEMP + A( L + I, J )*X( IX ) + IX = IX + INCX + 150 CONTINUE + X( JX ) = TEMP + JX = JX + INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* END OF DTBMV . +* + END +CUT HERE............ +CAT > DTRMV.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) +* .. SCALAR ARGUMENTS .. + INTEGER INCX, LDA, N + CHARACTER*1 DIAG, TRANS, UPLO +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), X( * ) +* .. +* +* PURPOSE +* ======= +* +* DTRMV PERFORMS ONE OF THE MATRIX-VECTOR OPERATIONS +* +* X := A*X, OR X := A'*X, +* +* WHERE X IS AN N ELEMENT VECTOR AND A IS AN N BY N UNIT, OR NON-UNIT, +* UPPER OR LOWER TRIANGULAR MATRIX. +* +* PARAMETERS +* ========== +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE MATRIX IS AN UPPER OR +* LOWER TRIANGULAR MATRIX AS FOLLOWS: +* +* UPLO = 'U' OR 'U' A IS AN UPPER TRIANGULAR MATRIX. +* +* UPLO = 'L' OR 'L' A IS A LOWER TRIANGULAR MATRIX. +* +* UNCHANGED ON EXIT. +* +* TRANS - CHARACTER*1. +* ON ENTRY, TRANS SPECIFIES THE OPERATION TO BE PERFORMED AS +* FOLLOWS: +* +* TRANS = 'N' OR 'N' X := A*X. +* +* TRANS = 'T' OR 'T' X := A'*X. +* +* TRANS = 'C' OR 'C' X := A'*X. +* +* UNCHANGED ON EXIT. +* +* DIAG - CHARACTER*1. +* ON ENTRY, DIAG SPECIFIES WHETHER OR NOT A IS UNIT +* TRIANGULAR AS FOLLOWS: +* +* DIAG = 'U' OR 'U' A IS ASSUMED TO BE UNIT TRIANGULAR. +* +* DIAG = 'N' OR 'N' A IS NOT ASSUMED TO BE UNIT +* TRIANGULAR. +* +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE ORDER OF THE MATRIX A. +* N MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, N ). +* BEFORE ENTRY WITH UPLO = 'U' OR 'U', THE LEADING N BY N +* UPPER TRIANGULAR PART OF THE ARRAY A MUST CONTAIN THE UPPER +* TRIANGULAR MATRIX AND THE STRICTLY LOWER TRIANGULAR PART OF +* A IS NOT REFERENCED. +* BEFORE ENTRY WITH UPLO = 'L' OR 'L', THE LEADING N BY N +* LOWER TRIANGULAR PART OF THE ARRAY A MUST CONTAIN THE LOWER +* TRIANGULAR MATRIX AND THE STRICTLY UPPER TRIANGULAR PART OF +* A IS NOT REFERENCED. +* NOTE THAT WHEN DIAG = 'U' OR 'U', THE DIAGONAL ELEMENTS OF +* A ARE NOT REFERENCED EITHER, BUT ARE ASSUMED TO BE UNITY. +* UNCHANGED ON EXIT. +* +* LDA - INTEGER. +* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDA MUST BE AT LEAST +* MAX( 1, N ). +* UNCHANGED ON EXIT. +* +* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCX ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE N +* ELEMENT VECTOR X. ON EXIT, X IS OVERWRITTEN WITH THE +* TRANFORMED VECTOR X. +* +* INCX - INTEGER. +* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* X. INCX MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* +* LEVEL 2 BLAS ROUTINE. +* +* -- WRITTEN ON 22-OCTOBER-1986. +* JACK DONGARRA, ARGONNE NATIONAL LAB. +* JEREMY DU CROZ, NAG CENTRAL OFFICE. +* SVEN HAMMARLING, NAG CENTRAL OFFICE. +* RICHARD HANSON, SANDIA NATIONAL LABS. +* +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. LOCAL SCALARS .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, J, JX, KX + LOGICAL NOUNIT +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO , 'U' ).AND. + $ .NOT.LSAME( UPLO , 'L' ) )THEN + INFO = 1 + ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 2 + ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. + $ .NOT.LSAME( DIAG , 'N' ) )THEN + INFO = 3 + ELSE IF( N.LT.0 )THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DTRMV ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( N.EQ.0 ) + $ RETURN +* + NOUNIT = LSAME( DIAG, 'N' ) +* +* SET UP THE START POINT IN X IF THE INCREMENT IS NOT UNITY. THIS +* WILL BE ( N - 1 )*INCX TOO SMALL FOR DESCENDING LOOPS. +* + IF( INCX.LE.0 )THEN + KX = 1 - ( N - 1 )*INCX + ELSE IF( INCX.NE.1 )THEN + KX = 1 + END IF +* +* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF A ARE +* ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH A. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* FORM X := A*X. +* + IF( LSAME( UPLO, 'U' ) )THEN + IF( INCX.EQ.1 )THEN + DO 20, J = 1, N + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + DO 10, I = 1, J - 1 + X( I ) = X( I ) + TEMP*A( I, J ) + 10 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*A( J, J ) + END IF + 20 CONTINUE + ELSE + JX = KX + DO 40, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + DO 30, I = 1, J - 1 + X( IX ) = X( IX ) + TEMP*A( I, J ) + IX = IX + INCX + 30 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*A( J, J ) + END IF + JX = JX + INCX + 40 CONTINUE + END IF + ELSE + IF( INCX.EQ.1 )THEN + DO 60, J = N, 1, -1 + IF( X( J ).NE.ZERO )THEN + TEMP = X( J ) + DO 50, I = N, J + 1, -1 + X( I ) = X( I ) + TEMP*A( I, J ) + 50 CONTINUE + IF( NOUNIT ) + $ X( J ) = X( J )*A( J, J ) + END IF + 60 CONTINUE + ELSE + KX = KX + ( N - 1 )*INCX + JX = KX + DO 80, J = N, 1, -1 + IF( X( JX ).NE.ZERO )THEN + TEMP = X( JX ) + IX = KX + DO 70, I = N, J + 1, -1 + X( IX ) = X( IX ) + TEMP*A( I, J ) + IX = IX - INCX + 70 CONTINUE + IF( NOUNIT ) + $ X( JX ) = X( JX )*A( J, J ) + END IF + JX = JX - INCX + 80 CONTINUE + END IF + END IF + ELSE +* +* FORM X := A'*X. +* + IF( LSAME( UPLO, 'U' ) )THEN + IF( INCX.EQ.1 )THEN + DO 100, J = N, 1, -1 + TEMP = X( J ) + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 90, I = J - 1, 1, -1 + TEMP = TEMP + A( I, J )*X( I ) + 90 CONTINUE + X( J ) = TEMP + 100 CONTINUE + ELSE + JX = KX + ( N - 1 )*INCX + DO 120, J = N, 1, -1 + TEMP = X( JX ) + IX = JX + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 110, I = J - 1, 1, -1 + IX = IX - INCX + TEMP = TEMP + A( I, J )*X( IX ) + 110 CONTINUE + X( JX ) = TEMP + JX = JX - INCX + 120 CONTINUE + END IF + ELSE + IF( INCX.EQ.1 )THEN + DO 140, J = 1, N + TEMP = X( J ) + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 130, I = J + 1, N + TEMP = TEMP + A( I, J )*X( I ) + 130 CONTINUE + X( J ) = TEMP + 140 CONTINUE + ELSE + JX = KX + DO 160, J = 1, N + TEMP = X( JX ) + IX = JX + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 150, I = J + 1, N + IX = IX + INCX + TEMP = TEMP + A( I, J )*X( IX ) + 150 CONTINUE + X( JX ) = TEMP + JX = JX + INCX + 160 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* END OF DTRMV . +* + END +CUT HERE............ +CAT > DSPMV.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) +* .. SCALAR ARGUMENTS .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, N + CHARACTER*1 UPLO +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION AP( * ), X( * ), Y( * ) +* .. +* +* PURPOSE +* ======= +* +* DSPMV PERFORMS THE MATRIX-VECTOR OPERATION +* +* Y := ALPHA*A*X + BETA*Y, +* +* WHERE ALPHA AND BETA ARE SCALARS, X AND Y ARE N ELEMENT VECTORS AND +* A IS AN N BY N SYMMETRIC MATRIX, SUPPLIED IN PACKED FORM. +* +* PARAMETERS +* ========== +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE UPPER OR LOWER +* TRIANGULAR PART OF THE MATRIX A IS SUPPLIED IN THE PACKED +* ARRAY AP AS FOLLOWS: +* +* UPLO = 'U' OR 'U' THE UPPER TRIANGULAR PART OF A IS +* SUPPLIED IN AP. +* +* UPLO = 'L' OR 'L' THE LOWER TRIANGULAR PART OF A IS +* SUPPLIED IN AP. +* +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE ORDER OF THE MATRIX A. +* N MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* ALPHA - DOUBLE PRECISION. +* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. +* UNCHANGED ON EXIT. +* +* AP - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( ( N*( N + 1 ) )/2 ). +* BEFORE ENTRY WITH UPLO = 'U' OR 'U', THE ARRAY AP MUST +* CONTAIN THE UPPER TRIANGULAR PART OF THE SYMMETRIC MATRIX +* PACKED SEQUENTIALLY, COLUMN BY COLUMN, SO THAT AP( 1 ) +* CONTAINS A( 1, 1 ), AP( 2 ) AND AP( 3 ) CONTAIN A( 1, 2 ) +* AND A( 2, 2 ) RESPECTIVELY, AND SO ON. +* BEFORE ENTRY WITH UPLO = 'L' OR 'L', THE ARRAY AP MUST +* CONTAIN THE LOWER TRIANGULAR PART OF THE SYMMETRIC MATRIX +* PACKED SEQUENTIALLY, COLUMN BY COLUMN, SO THAT AP( 1 ) +* CONTAINS A( 1, 1 ), AP( 2 ) AND AP( 3 ) CONTAIN A( 2, 1 ) +* AND A( 3, 1 ) RESPECTIVELY, AND SO ON. +* UNCHANGED ON EXIT. +* +* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCX ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE N +* ELEMENT VECTOR X. +* UNCHANGED ON EXIT. +* +* INCX - INTEGER. +* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* X. INCX MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* BETA - DOUBLE PRECISION. +* ON ENTRY, BETA SPECIFIES THE SCALAR BETA. WHEN BETA IS +* SUPPLIED AS ZERO THEN Y NEED NOT BE SET ON INPUT. +* UNCHANGED ON EXIT. +* +* Y - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCY ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY Y MUST CONTAIN THE N +* ELEMENT VECTOR Y. ON EXIT, Y IS OVERWRITTEN BY THE UPDATED +* VECTOR Y. +* +* INCY - INTEGER. +* ON ENTRY, INCY SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* Y. INCY MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* +* LEVEL 2 BLAS ROUTINE. +* +* -- WRITTEN ON 22-OCTOBER-1986. +* JACK DONGARRA, ARGONNE NATIONAL LAB. +* JEREMY DU CROZ, NAG CENTRAL OFFICE. +* SVEN HAMMARLING, NAG CENTRAL OFFICE. +* RICHARD HANSON, SANDIA NATIONAL LABS. +* +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. LOCAL SCALARS .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( INCX.EQ.0 )THEN + INFO = 6 + ELSE IF( INCY.EQ.0 )THEN + INFO = 9 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSPMV ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* SET UP THE START POINTS IN X AND Y. +* + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF +* +* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF THE ARRAY AP +* ARE ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH AP. +* +* FIRST FORM Y := BETA*Y. +* + IF( BETA.NE.ONE )THEN + IF( INCY.EQ.1 )THEN + IF( BETA.EQ.ZERO )THEN + DO 10, I = 1, N + Y( I ) = ZERO + 10 CONTINUE + ELSE + DO 20, I = 1, N + Y( I ) = BETA*Y( I ) + 20 CONTINUE + END IF + ELSE + IY = KY + IF( BETA.EQ.ZERO )THEN + DO 30, I = 1, N + Y( IY ) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40, I = 1, N + Y( IY ) = BETA*Y( IY ) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF( ALPHA.EQ.ZERO ) + $ RETURN + KK = 1 + IF( LSAME( UPLO, 'U' ) )THEN +* +* FORM Y WHEN AP CONTAINS THE UPPER TRIANGLE. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60, J = 1, N + TEMP1 = ALPHA*X( J ) + TEMP2 = ZERO + K = KK + DO 50, I = 1, J - 1 + Y( I ) = Y( I ) + TEMP1*AP( K ) + TEMP2 = TEMP2 + AP( K )*X( I ) + K = K + 1 + 50 CONTINUE + Y( J ) = Y( J ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 + KK = KK + J + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80, J = 1, N + TEMP1 = ALPHA*X( JX ) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70, K = KK, KK + J - 2 + Y( IY ) = Y( IY ) + TEMP1*AP( K ) + TEMP2 = TEMP2 + AP( K )*X( IX ) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y( JY ) = Y( JY ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + KK = KK + J + 80 CONTINUE + END IF + ELSE +* +* FORM Y WHEN AP CONTAINS THE LOWER TRIANGLE. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 100, J = 1, N + TEMP1 = ALPHA*X( J ) + TEMP2 = ZERO + Y( J ) = Y( J ) + TEMP1*AP( KK ) + K = KK + 1 + DO 90, I = J + 1, N + Y( I ) = Y( I ) + TEMP1*AP( K ) + TEMP2 = TEMP2 + AP( K )*X( I ) + K = K + 1 + 90 CONTINUE + Y( J ) = Y( J ) + ALPHA*TEMP2 + KK = KK + ( N - J + 1 ) + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120, J = 1, N + TEMP1 = ALPHA*X( JX ) + TEMP2 = ZERO + Y( JY ) = Y( JY ) + TEMP1*AP( KK ) + IX = JX + IY = JY + DO 110, K = KK + 1, KK + N - J + IX = IX + INCX + IY = IY + INCY + Y( IY ) = Y( IY ) + TEMP1*AP( K ) + TEMP2 = TEMP2 + AP( K )*X( IX ) + 110 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + KK = KK + ( N - J + 1 ) + 120 CONTINUE + END IF + END IF +* + RETURN +* +* END OF DSPMV . +* + END +CUT HERE............ +CAT > DSBMV.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DSBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX, + $ BETA, Y, INCY ) +* .. SCALAR ARGUMENTS .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, K, LDA, N + CHARACTER*1 UPLO +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* PURPOSE +* ======= +* +* DSBMV PERFORMS THE MATRIX-VECTOR OPERATION +* +* Y := ALPHA*A*X + BETA*Y, +* +* WHERE ALPHA AND BETA ARE SCALARS, X AND Y ARE N ELEMENT VECTORS AND +* A IS AN N BY N SYMMETRIC BAND MATRIX, WITH K SUPER-DIAGONALS. +* +* PARAMETERS +* ========== +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE UPPER OR LOWER +* TRIANGULAR PART OF THE BAND MATRIX A IS BEING SUPPLIED AS +* FOLLOWS: +* +* UPLO = 'U' OR 'U' THE UPPER TRIANGULAR PART OF A IS +* BEING SUPPLIED. +* +* UPLO = 'L' OR 'L' THE LOWER TRIANGULAR PART OF A IS +* BEING SUPPLIED. +* +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE ORDER OF THE MATRIX A. +* N MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* K - INTEGER. +* ON ENTRY, K SPECIFIES THE NUMBER OF SUPER-DIAGONALS OF THE +* MATRIX A. K MUST SATISFY 0 .LE. K. +* UNCHANGED ON EXIT. +* +* ALPHA - DOUBLE PRECISION. +* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. +* UNCHANGED ON EXIT. +* +* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, N ). +* BEFORE ENTRY WITH UPLO = 'U' OR 'U', THE LEADING ( K + 1 ) +* BY N PART OF THE ARRAY A MUST CONTAIN THE UPPER TRIANGULAR +* BAND PART OF THE SYMMETRIC MATRIX, SUPPLIED COLUMN BY +* COLUMN, WITH THE LEADING DIAGONAL OF THE MATRIX IN ROW +* ( K + 1 ) OF THE ARRAY, THE FIRST SUPER-DIAGONAL STARTING AT +* POSITION 2 IN ROW K, AND SO ON. THE TOP LEFT K BY K TRIANGLE +* OF THE ARRAY A IS NOT REFERENCED. +* THE FOLLOWING PROGRAM SEGMENT WILL TRANSFER THE UPPER +* TRIANGULAR PART OF A SYMMETRIC BAND MATRIX FROM CONVENTIONAL +* FULL MATRIX STORAGE TO BAND STORAGE: +* +* DO 20, J = 1, N +* M = K + 1 - J +* DO 10, I = MAX( 1, J - K ), J +* A( M + I, J ) = MATRIX( I, J ) +* 10 CONTINUE +* 20 CONTINUE +* +* BEFORE ENTRY WITH UPLO = 'L' OR 'L', THE LEADING ( K + 1 ) +* BY N PART OF THE ARRAY A MUST CONTAIN THE LOWER TRIANGULAR +* BAND PART OF THE SYMMETRIC MATRIX, SUPPLIED COLUMN BY +* COLUMN, WITH THE LEADING DIAGONAL OF THE MATRIX IN ROW 1 OF +* THE ARRAY, THE FIRST SUB-DIAGONAL STARTING AT POSITION 1 IN +* ROW 2, AND SO ON. THE BOTTOM RIGHT K BY K TRIANGLE OF THE +* ARRAY A IS NOT REFERENCED. +* THE FOLLOWING PROGRAM SEGMENT WILL TRANSFER THE LOWER +* TRIANGULAR PART OF A SYMMETRIC BAND MATRIX FROM CONVENTIONAL +* FULL MATRIX STORAGE TO BAND STORAGE: +* +* DO 20, J = 1, N +* M = 1 - J +* DO 10, I = J, MIN( N, J + K ) +* A( M + I, J ) = MATRIX( I, J ) +* 10 CONTINUE +* 20 CONTINUE +* +* UNCHANGED ON EXIT. +* +* LDA - INTEGER. +* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDA MUST BE AT LEAST +* ( K + 1 ). +* UNCHANGED ON EXIT. +* +* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCX ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE +* VECTOR X. +* UNCHANGED ON EXIT. +* +* INCX - INTEGER. +* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* X. INCX MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* BETA - DOUBLE PRECISION. +* ON ENTRY, BETA SPECIFIES THE SCALAR BETA. +* UNCHANGED ON EXIT. +* +* Y - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCY ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY Y MUST CONTAIN THE +* VECTOR Y. ON EXIT, Y IS OVERWRITTEN BY THE UPDATED VECTOR Y. +* +* INCY - INTEGER. +* ON ENTRY, INCY SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* Y. INCY MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* +* LEVEL 2 BLAS ROUTINE. +* +* -- WRITTEN ON 22-OCTOBER-1986. +* JACK DONGARRA, ARGONNE NATIONAL LAB. +* JEREMY DU CROZ, NAG CENTRAL OFFICE. +* SVEN HAMMARLING, NAG CENTRAL OFFICE. +* RICHARD HANSON, SANDIA NATIONAL LABS. +* +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. LOCAL SCALARS .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( K.LT.0 )THEN + INFO = 3 + ELSE IF( LDA.LT.( K + 1 ) )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + ELSE IF( INCY.EQ.0 )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSBMV ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* SET UP THE START POINTS IN X AND Y. +* + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF +* +* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF THE ARRAY A +* ARE ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH A. +* +* FIRST FORM Y := BETA*Y. +* + IF( BETA.NE.ONE )THEN + IF( INCY.EQ.1 )THEN + IF( BETA.EQ.ZERO )THEN + DO 10, I = 1, N + Y( I ) = ZERO + 10 CONTINUE + ELSE + DO 20, I = 1, N + Y( I ) = BETA*Y( I ) + 20 CONTINUE + END IF + ELSE + IY = KY + IF( BETA.EQ.ZERO )THEN + DO 30, I = 1, N + Y( IY ) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40, I = 1, N + Y( IY ) = BETA*Y( IY ) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF( ALPHA.EQ.ZERO ) + $ RETURN + IF( LSAME( UPLO, 'U' ) )THEN +* +* FORM Y WHEN UPPER TRIANGLE OF A IS STORED. +* + KPLUS1 = K + 1 + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60, J = 1, N + TEMP1 = ALPHA*X( J ) + TEMP2 = ZERO + L = KPLUS1 - J + DO 50, I = MAX( 1, J - K ), J - 1 + Y( I ) = Y( I ) + TEMP1*A( L + I, J ) + TEMP2 = TEMP2 + A( L + I, J )*X( I ) + 50 CONTINUE + Y( J ) = Y( J ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80, J = 1, N + TEMP1 = ALPHA*X( JX ) + TEMP2 = ZERO + IX = KX + IY = KY + L = KPLUS1 - J + DO 70, I = MAX( 1, J - K ), J - 1 + Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) + TEMP2 = TEMP2 + A( L + I, J )*X( IX ) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y( JY ) = Y( JY ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + IF( J.GT.K )THEN + KX = KX + INCX + KY = KY + INCY + END IF + 80 CONTINUE + END IF + ELSE +* +* FORM Y WHEN LOWER TRIANGLE OF A IS STORED. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 100, J = 1, N + TEMP1 = ALPHA*X( J ) + TEMP2 = ZERO + Y( J ) = Y( J ) + TEMP1*A( 1, J ) + L = 1 - J + DO 90, I = J + 1, MIN( N, J + K ) + Y( I ) = Y( I ) + TEMP1*A( L + I, J ) + TEMP2 = TEMP2 + A( L + I, J )*X( I ) + 90 CONTINUE + Y( J ) = Y( J ) + ALPHA*TEMP2 + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120, J = 1, N + TEMP1 = ALPHA*X( JX ) + TEMP2 = ZERO + Y( JY ) = Y( JY ) + TEMP1*A( 1, J ) + L = 1 - J + IX = JX + IY = JY + DO 110, I = J + 1, MIN( N, J + K ) + IX = IX + INCX + IY = IY + INCY + Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) + TEMP2 = TEMP2 + A( L + I, J )*X( IX ) + 110 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* END OF DSBMV . +* + END +CUT HERE............ +CAT > DSYMV.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX, + $ BETA, Y, INCY ) +* .. SCALAR ARGUMENTS .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDA, N + CHARACTER*1 UPLO +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* PURPOSE +* ======= +* +* DSYMV PERFORMS THE MATRIX-VECTOR OPERATION +* +* Y := ALPHA*A*X + BETA*Y, +* +* WHERE ALPHA AND BETA ARE SCALARS, X AND Y ARE N ELEMENT VECTORS AND +* A IS AN N BY N SYMMETRIC MATRIX. +* +* PARAMETERS +* ========== +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE UPPER OR LOWER +* TRIANGULAR PART OF THE ARRAY A IS TO BE REFERENCED AS +* FOLLOWS: +* +* UPLO = 'U' OR 'U' ONLY THE UPPER TRIANGULAR PART OF A +* IS TO BE REFERENCED. +* +* UPLO = 'L' OR 'L' ONLY THE LOWER TRIANGULAR PART OF A +* IS TO BE REFERENCED. +* +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE ORDER OF THE MATRIX A. +* N MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* ALPHA - DOUBLE PRECISION. +* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. +* UNCHANGED ON EXIT. +* +* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, N ). +* BEFORE ENTRY WITH UPLO = 'U' OR 'U', THE LEADING N BY N +* UPPER TRIANGULAR PART OF THE ARRAY A MUST CONTAIN THE UPPER +* TRIANGULAR PART OF THE SYMMETRIC MATRIX AND THE STRICTLY +* LOWER TRIANGULAR PART OF A IS NOT REFERENCED. +* BEFORE ENTRY WITH UPLO = 'L' OR 'L', THE LEADING N BY N +* LOWER TRIANGULAR PART OF THE ARRAY A MUST CONTAIN THE LOWER +* TRIANGULAR PART OF THE SYMMETRIC MATRIX AND THE STRICTLY +* UPPER TRIANGULAR PART OF A IS NOT REFERENCED. +* UNCHANGED ON EXIT. +* +* LDA - INTEGER. +* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDA MUST BE AT LEAST +* MAX( 1, N ). +* UNCHANGED ON EXIT. +* +* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCX ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE N +* ELEMENT VECTOR X. +* UNCHANGED ON EXIT. +* +* INCX - INTEGER. +* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* X. INCX MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* BETA - DOUBLE PRECISION. +* ON ENTRY, BETA SPECIFIES THE SCALAR BETA. WHEN BETA IS +* SUPPLIED AS ZERO THEN Y NEED NOT BE SET ON INPUT. +* UNCHANGED ON EXIT. +* +* Y - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCY ) ). +* BEFORE ENTRY, THE INCREMENTED ARRAY Y MUST CONTAIN THE N +* ELEMENT VECTOR Y. ON EXIT, Y IS OVERWRITTEN BY THE UPDATED +* VECTOR Y. +* +* INCY - INTEGER. +* ON ENTRY, INCY SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* Y. INCY MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* +* LEVEL 2 BLAS ROUTINE. +* +* -- WRITTEN ON 22-OCTOBER-1986. +* JACK DONGARRA, ARGONNE NATIONAL LAB. +* JEREMY DU CROZ, NAG CENTRAL OFFICE. +* SVEN HAMMARLING, NAG CENTRAL OFFICE. +* RICHARD HANSON, SANDIA NATIONAL LABS. +* +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. LOCAL SCALARS .. + DOUBLE PRECISION TEMP1, TEMP2 + INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF ( .NOT.LSAME( UPLO, 'U' ).AND. + $ .NOT.LSAME( UPLO, 'L' ) )THEN + INFO = 1 + ELSE IF( N.LT.0 )THEN + INFO = 2 + ELSE IF( LDA.LT.MAX( 1, N ) )THEN + INFO = 5 + ELSE IF( INCX.EQ.0 )THEN + INFO = 7 + ELSE IF( INCY.EQ.0 )THEN + INFO = 10 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYMV ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* SET UP THE START POINTS IN X AND Y. +* + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( N - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( N - 1 )*INCY + END IF +* +* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF A ARE +* ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH THE TRIANGULAR PART +* OF A. +* +* FIRST FORM Y := BETA*Y. +* + IF( BETA.NE.ONE )THEN + IF( INCY.EQ.1 )THEN + IF( BETA.EQ.ZERO )THEN + DO 10, I = 1, N + Y( I ) = ZERO + 10 CONTINUE + ELSE + DO 20, I = 1, N + Y( I ) = BETA*Y( I ) + 20 CONTINUE + END IF + ELSE + IY = KY + IF( BETA.EQ.ZERO )THEN + DO 30, I = 1, N + Y( IY ) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40, I = 1, N + Y( IY ) = BETA*Y( IY ) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF( ALPHA.EQ.ZERO ) + $ RETURN + IF( LSAME( UPLO, 'U' ) )THEN +* +* FORM Y WHEN A IS STORED IN UPPER TRIANGLE. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 60, J = 1, N + TEMP1 = ALPHA*X( J ) + TEMP2 = ZERO + DO 50, I = 1, J - 1 + Y( I ) = Y( I ) + TEMP1*A( I, J ) + TEMP2 = TEMP2 + A( I, J )*X( I ) + 50 CONTINUE + Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2 + 60 CONTINUE + ELSE + JX = KX + JY = KY + DO 80, J = 1, N + TEMP1 = ALPHA*X( JX ) + TEMP2 = ZERO + IX = KX + IY = KY + DO 70, I = 1, J - 1 + Y( IY ) = Y( IY ) + TEMP1*A( I, J ) + TEMP2 = TEMP2 + A( I, J )*X( IX ) + IX = IX + INCX + IY = IY + INCY + 70 CONTINUE + Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 80 CONTINUE + END IF + ELSE +* +* FORM Y WHEN A IS STORED IN LOWER TRIANGLE. +* + IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN + DO 100, J = 1, N + TEMP1 = ALPHA*X( J ) + TEMP2 = ZERO + Y( J ) = Y( J ) + TEMP1*A( J, J ) + DO 90, I = J + 1, N + Y( I ) = Y( I ) + TEMP1*A( I, J ) + TEMP2 = TEMP2 + A( I, J )*X( I ) + 90 CONTINUE + Y( J ) = Y( J ) + ALPHA*TEMP2 + 100 CONTINUE + ELSE + JX = KX + JY = KY + DO 120, J = 1, N + TEMP1 = ALPHA*X( JX ) + TEMP2 = ZERO + Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + IX = JX + IY = JY + DO 110, I = J + 1, N + IX = IX + INCX + IY = IY + INCY + Y( IY ) = Y( IY ) + TEMP1*A( I, J ) + TEMP2 = TEMP2 + A( I, J )*X( IX ) + 110 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP2 + JX = JX + INCX + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* END OF DSYMV . +* + END +CUT HERE............ +CAT > DGBMV.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, + $ BETA, Y, INCY ) +* .. SCALAR ARGUMENTS .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, KL, KU, LDA, M, N + CHARACTER*1 TRANS +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* PURPOSE +* ======= +* +* DGBMV PERFORMS ONE OF THE MATRIX-VECTOR OPERATIONS +* +* Y := ALPHA*A*X + BETA*Y, OR Y := ALPHA*A'*X + BETA*Y, +* +* WHERE ALPHA AND BETA ARE SCALARS, X AND Y ARE VECTORS AND A IS AN +* M BY N BAND MATRIX, WITH KL SUB-DIAGONALS AND KU SUPER-DIAGONALS. +* +* PARAMETERS +* ========== +* +* TRANS - CHARACTER*1. +* ON ENTRY, TRANS SPECIFIES THE OPERATION TO BE PERFORMED AS +* FOLLOWS: +* +* TRANS = 'N' OR 'N' Y := ALPHA*A*X + BETA*Y. +* +* TRANS = 'T' OR 'T' Y := ALPHA*A'*X + BETA*Y. +* +* TRANS = 'C' OR 'C' Y := ALPHA*A'*X + BETA*Y. +* +* UNCHANGED ON EXIT. +* +* M - INTEGER. +* ON ENTRY, M SPECIFIES THE NUMBER OF ROWS OF THE MATRIX A. +* M MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE NUMBER OF COLUMNS OF THE MATRIX A. +* N MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* KL - INTEGER. +* ON ENTRY, KL SPECIFIES THE NUMBER OF SUB-DIAGONALS OF THE +* MATRIX A. KL MUST SATISFY 0 .LE. KL. +* UNCHANGED ON EXIT. +* +* KU - INTEGER. +* ON ENTRY, KU SPECIFIES THE NUMBER OF SUPER-DIAGONALS OF THE +* MATRIX A. KU MUST SATISFY 0 .LE. KU. +* UNCHANGED ON EXIT. +* +* ALPHA - DOUBLE PRECISION. +* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. +* UNCHANGED ON EXIT. +* +* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, N ). +* BEFORE ENTRY, THE LEADING ( KL + KU + 1 ) BY N PART OF THE +* ARRAY A MUST CONTAIN THE MATRIX OF COEFFICIENTS, SUPPLIED +* COLUMN BY COLUMN, WITH THE LEADING DIAGONAL OF THE MATRIX IN +* ROW ( KU + 1 ) OF THE ARRAY, THE FIRST SUPER-DIAGONAL +* STARTING AT POSITION 2 IN ROW KU, THE FIRST SUB-DIAGONAL +* STARTING AT POSITION 1 IN ROW ( KU + 2 ), AND SO ON. +* ELEMENTS IN THE ARRAY A THAT DO NOT CORRESPOND TO ELEMENTS +* IN THE BAND MATRIX (SUCH AS THE TOP LEFT KU BY KU TRIANGLE) +* ARE NOT REFERENCED. +* THE FOLLOWING PROGRAM SEGMENT WILL TRANSFER A BAND MATRIX +* FROM CONVENTIONAL FULL MATRIX STORAGE TO BAND STORAGE: +* +* DO 20, J = 1, N +* K = KU + 1 - J +* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) +* A( K + I, J ) = MATRIX( I, J ) +* 10 CONTINUE +* 20 CONTINUE +* +* UNCHANGED ON EXIT. +* +* LDA - INTEGER. +* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDA MUST BE AT LEAST +* ( KL + KU + 1 ). +* UNCHANGED ON EXIT. +* +* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCX ) ) WHEN TRANS = 'N' OR 'N' +* AND AT LEAST +* ( 1 + ( M - 1 )*ABS( INCX ) ) OTHERWISE. +* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE +* VECTOR X. +* UNCHANGED ON EXIT. +* +* INCX - INTEGER. +* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* X. INCX MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* BETA - DOUBLE PRECISION. +* ON ENTRY, BETA SPECIFIES THE SCALAR BETA. WHEN BETA IS +* SUPPLIED AS ZERO THEN Y NEED NOT BE SET ON INPUT. +* UNCHANGED ON EXIT. +* +* Y - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( M - 1 )*ABS( INCY ) ) WHEN TRANS = 'N' OR 'N' +* AND AT LEAST +* ( 1 + ( N - 1 )*ABS( INCY ) ) OTHERWISE. +* BEFORE ENTRY, THE INCREMENTED ARRAY Y MUST CONTAIN THE +* VECTOR Y. ON EXIT, Y IS OVERWRITTEN BY THE UPDATED VECTOR Y. +* +* INCY - INTEGER. +* ON ENTRY, INCY SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* Y. INCY MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* +* LEVEL 2 BLAS ROUTINE. +* +* -- WRITTEN ON 22-OCTOBER-1986. +* JACK DONGARRA, ARGONNE NATIONAL LAB. +* JEREMY DU CROZ, NAG CENTRAL OFFICE. +* SVEN HAMMARLING, NAG CENTRAL OFFICE. +* RICHARD HANSON, SANDIA NATIONAL LABS. +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. LOCAL SCALARS .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, + $ LENX, LENY +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF ( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 1 + ELSE IF( M.LT.0 )THEN + INFO = 2 + ELSE IF( N.LT.0 )THEN + INFO = 3 + ELSE IF( KL.LT.0 )THEN + INFO = 4 + ELSE IF( KU.LT.0 )THEN + INFO = 5 + ELSE IF( LDA.LT.( KL + KU + 1 ) )THEN + INFO = 8 + ELSE IF( INCX.EQ.0 )THEN + INFO = 10 + ELSE IF( INCY.EQ.0 )THEN + INFO = 13 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DGBMV ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* SET LENX AND LENY, THE LENGTHS OF THE VECTORS X AND Y, AND SET +* UP THE START POINTS IN X AND Y. +* + IF( LSAME( TRANS, 'N' ) )THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( LENX - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( LENY - 1 )*INCY + END IF +* +* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF A ARE +* ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH THE BAND PART OF A. +* +* FIRST FORM Y := BETA*Y. +* + IF( BETA.NE.ONE )THEN + IF( INCY.EQ.1 )THEN + IF( BETA.EQ.ZERO )THEN + DO 10, I = 1, LENY + Y( I ) = ZERO + 10 CONTINUE + ELSE + DO 20, I = 1, LENY + Y( I ) = BETA*Y( I ) + 20 CONTINUE + END IF + ELSE + IY = KY + IF( BETA.EQ.ZERO )THEN + DO 30, I = 1, LENY + Y( IY ) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40, I = 1, LENY + Y( IY ) = BETA*Y( IY ) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF( ALPHA.EQ.ZERO ) + $ RETURN + KUP1 = KU + 1 + IF( LSAME( TRANS, 'N' ) )THEN +* +* FORM Y := ALPHA*A*X + Y. +* + JX = KX + IF( INCY.EQ.1 )THEN + DO 60, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + K = KUP1 - J + DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL ) + Y( I ) = Y( I ) + TEMP*A( K + I, J ) + 50 CONTINUE + END IF + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + IY = KY + K = KUP1 - J + DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL ) + Y( IY ) = Y( IY ) + TEMP*A( K + I, J ) + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + IF( J.GT.KU ) + $ KY = KY + INCY + 80 CONTINUE + END IF + ELSE +* +* FORM Y := ALPHA*A'*X + Y. +* + JY = KY + IF( INCX.EQ.1 )THEN + DO 100, J = 1, N + TEMP = ZERO + K = KUP1 - J + DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL ) + TEMP = TEMP + A( K + I, J )*X( I ) + 90 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP + JY = JY + INCY + 100 CONTINUE + ELSE + DO 120, J = 1, N + TEMP = ZERO + IX = KX + K = KUP1 - J + DO 110, I = MAX( 1, J - KU ), MIN( M, J + KL ) + TEMP = TEMP + A( K + I, J )*X( IX ) + IX = IX + INCX + 110 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP + JY = JY + INCY + IF( J.GT.KU ) + $ KX = KX + INCX + 120 CONTINUE + END IF + END IF +* + RETURN +* +* END OF DGBMV . +* + END +CUT HERE............ +CAT > DGEMV.F <<'CUT HERE............' +* +************************************************************************ +* +* FILE OF THE DOUBLE PRECISION LEVEL-2 BLAS. +* =========================================== +* +* SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, +* $ BETA, Y, INCY ) +* +* SUBROUTINE DGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, +* $ BETA, Y, INCY ) +* +* SUBROUTINE DSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX, +* $ BETA, Y, INCY ) +* +* SUBROUTINE DSBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX, +* $ BETA, Y, INCY ) +* +* SUBROUTINE DSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) +* +* SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) +* +* SUBROUTINE DTBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) +* +* SUBROUTINE DTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) +* +* SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) +* +* SUBROUTINE DTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) +* +* SUBROUTINE DTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) +* +* SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) +* +* SUBROUTINE DSYR ( UPLO, N, ALPHA, X, INCX, A, LDA ) +* +* SUBROUTINE DSPR ( UPLO, N, ALPHA, X, INCX, AP ) +* +* SUBROUTINE DSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) +* +* SUBROUTINE DSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) +* +* SEE: +* +* DONGARRA J. J., DU CROZ J. J., HAMMARLING S. AND HANSON R. J.. +* AN EXTENDED SET OF FORTRAN BASIC LINEAR ALGEBRA SUBPROGRAMS. +* +* TECHNICAL MEMORANDA NOS. 41 (REVISION 3) AND 81, MATHEMATICS +* AND COMPUTER SCIENCE DIVISION, ARGONNE NATIONAL LABORATORY, +* 9700 SOUTH CASS AVENUE, ARGONNE, ILLINOIS 60439, US. +* +* OR +* +* NAG TECHNICAL REPORTS TR3/87 AND TR4/87, NUMERICAL ALGORITHMS +* GROUP LTD., NAG CENTRAL OFFICE, 256 BANBURY ROAD, OXFORD +* OX2 7DE, UK, AND NUMERICAL ALGORITHMS GROUP INC., 1101 31ST +* STREET, SUITE 100, DOWNERS GROVE, ILLINOIS 60515-1263, USA. +* +************************************************************************ +* + SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, + $ BETA, Y, INCY ) +* .. SCALAR ARGUMENTS .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDA, M, N + CHARACTER*1 TRANS +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* PURPOSE +* ======= +* +* DGEMV PERFORMS ONE OF THE MATRIX-VECTOR OPERATIONS +* +* Y := ALPHA*A*X + BETA*Y, OR Y := ALPHA*A'*X + BETA*Y, +* +* WHERE ALPHA AND BETA ARE SCALARS, X AND Y ARE VECTORS AND A IS AN +* M BY N MATRIX. +* +* PARAMETERS +* ========== +* +* TRANS - CHARACTER*1. +* ON ENTRY, TRANS SPECIFIES THE OPERATION TO BE PERFORMED AS +* FOLLOWS: +* +* TRANS = 'N' OR 'N' Y := ALPHA*A*X + BETA*Y. +* +* TRANS = 'T' OR 'T' Y := ALPHA*A'*X + BETA*Y. +* +* TRANS = 'C' OR 'C' Y := ALPHA*A'*X + BETA*Y. +* +* UNCHANGED ON EXIT. +* +* M - INTEGER. +* ON ENTRY, M SPECIFIES THE NUMBER OF ROWS OF THE MATRIX A. +* M MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE NUMBER OF COLUMNS OF THE MATRIX A. +* N MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* ALPHA - DOUBLE PRECISION. +* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. +* UNCHANGED ON EXIT. +* +* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, N ). +* BEFORE ENTRY, THE LEADING M BY N PART OF THE ARRAY A MUST +* CONTAIN THE MATRIX OF COEFFICIENTS. +* UNCHANGED ON EXIT. +* +* LDA - INTEGER. +* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDA MUST BE AT LEAST +* MAX( 1, M ). +* UNCHANGED ON EXIT. +* +* X - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( N - 1 )*ABS( INCX ) ) WHEN TRANS = 'N' OR 'N' +* AND AT LEAST +* ( 1 + ( M - 1 )*ABS( INCX ) ) OTHERWISE. +* BEFORE ENTRY, THE INCREMENTED ARRAY X MUST CONTAIN THE +* VECTOR X. +* UNCHANGED ON EXIT. +* +* INCX - INTEGER. +* ON ENTRY, INCX SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* X. INCX MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* BETA - DOUBLE PRECISION. +* ON ENTRY, BETA SPECIFIES THE SCALAR BETA. WHEN BETA IS +* SUPPLIED AS ZERO THEN Y NEED NOT BE SET ON INPUT. +* UNCHANGED ON EXIT. +* +* Y - DOUBLE PRECISION ARRAY OF DIMENSION AT LEAST +* ( 1 + ( M - 1 )*ABS( INCY ) ) WHEN TRANS = 'N' OR 'N' +* AND AT LEAST +* ( 1 + ( N - 1 )*ABS( INCY ) ) OTHERWISE. +* BEFORE ENTRY WITH BETA NON-ZERO, THE INCREMENTED ARRAY Y +* MUST CONTAIN THE VECTOR Y. ON EXIT, Y IS OVERWRITTEN BY THE +* UPDATED VECTOR Y. +* +* INCY - INTEGER. +* ON ENTRY, INCY SPECIFIES THE INCREMENT FOR THE ELEMENTS OF +* Y. INCY MUST NOT BE ZERO. +* UNCHANGED ON EXIT. +* +* +* LEVEL 2 BLAS ROUTINE. +* +* -- WRITTEN ON 22-OCTOBER-1986. +* JACK DONGARRA, ARGONNE NATIONAL LAB. +* JEREMY DU CROZ, NAG CENTRAL OFFICE. +* SVEN HAMMARLING, NAG CENTRAL OFFICE. +* RICHARD HANSON, SANDIA NATIONAL LABS. +* +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. LOCAL SCALARS .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF ( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 1 + ELSE IF( M.LT.0 )THEN + INFO = 2 + ELSE IF( N.LT.0 )THEN + INFO = 3 + ELSE IF( LDA.LT.MAX( 1, M ) )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + ELSE IF( INCY.EQ.0 )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DGEMV ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* SET LENX AND LENY, THE LENGTHS OF THE VECTORS X AND Y, AND SET +* UP THE START POINTS IN X AND Y. +* + IF( LSAME( TRANS, 'N' ) )THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( LENX - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( LENY - 1 )*INCY + END IF +* +* START THE OPERATIONS. IN THIS VERSION THE ELEMENTS OF A ARE +* ACCESSED SEQUENTIALLY WITH ONE PASS THROUGH A. +* +* FIRST FORM Y := BETA*Y. +* + IF( BETA.NE.ONE )THEN + IF( INCY.EQ.1 )THEN + IF( BETA.EQ.ZERO )THEN + DO 10, I = 1, LENY + Y( I ) = ZERO + 10 CONTINUE + ELSE + DO 20, I = 1, LENY + Y( I ) = BETA*Y( I ) + 20 CONTINUE + END IF + ELSE + IY = KY + IF( BETA.EQ.ZERO )THEN + DO 30, I = 1, LENY + Y( IY ) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40, I = 1, LENY + Y( IY ) = BETA*Y( IY ) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF( ALPHA.EQ.ZERO ) + $ RETURN + IF( LSAME( TRANS, 'N' ) )THEN +* +* FORM Y := ALPHA*A*X + Y. +* + JX = KX + IF( INCY.EQ.1 )THEN + DO 60, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + DO 50, I = 1, M + Y( I ) = Y( I ) + TEMP*A( I, J ) + 50 CONTINUE + END IF + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + IY = KY + DO 70, I = 1, M + Y( IY ) = Y( IY ) + TEMP*A( I, J ) + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + ELSE +* +* FORM Y := ALPHA*A'*X + Y. +* + JY = KY + IF( INCX.EQ.1 )THEN + DO 100, J = 1, N + TEMP = ZERO + DO 90, I = 1, M + TEMP = TEMP + A( I, J )*X( I ) + 90 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP + JY = JY + INCY + 100 CONTINUE + ELSE + DO 120, J = 1, N + TEMP = ZERO + IX = KX + DO 110, I = 1, M + TEMP = TEMP + A( I, J )*X( IX ) + IX = IX + INCX + 110 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* END OF DGEMV . +* + END +CUT HERE............ +C FOLLOWING FROM V12X CODE FROM JMH + SUBROUTINE XERBLA ( SRNAME, INFO ) +* .. Scalar Arguments .. + INTEGER INFO + CHARACTER*6 SRNAME +* .. +* +* Purpose +* ======= +* +* XERBLA is an error handler for the Level 2 BLAS routines. +* +* It is called by the Level 2 BLAS routines if an input parameter is +* invalid. +* +* Installers should consider modifying the STOP statement in order to +* call system-specific exception-handling facilities. +* +* Parameters +* ========== +* +* SRNAME - CHARACTER*6. +* On entry, SRNAME specifies the name of the routine which +* called XERBLA. +* +* INFO - INTEGER. +* On entry, INFO specifies the position of the invalid +* parameter in the parameter-list of the calling routine. +* +* +* Auxiliary routine for Level 2 Blas. +* +* Written on 20-July-1986. +* +* .. Executable Statements .. +* + WRITE (*,99999) SRNAME, INFO +* + STOP +* +99999 FORMAT ( ' ** On entry to ', A6, ' parameter number ', I2, + $ ' had an illegal value' ) +* +* End of XERBLA. +* + END + LOGICAL FUNCTION LSAME ( CA, CB ) +* .. Scalar Arguments .. + CHARACTER*1 CA, CB +* .. +* +* Purpose +* ======= +* +* LSAME tests if CA is the same letter as CB regardless of case. +* CB is assumed to be an upper case letter. LSAME returns .TRUE. if +* CA is either the same as CB or the equivalent lower case letter. +* +* N.B. This version of the routine is only correct for ASCII code. +* Installers must modify the routine for other character-codes. +* +* For EBCDIC systems the constant IOFF must be changed to -64. +* For CDC systems using 6-12 bit representations, the system- +* specific code in comments must be activated. +* +* Parameters +* ========== +* +* CA - CHARACTER*1 +* CB - CHARACTER*1 +* On entry, CA and CB specify characters to be compared. +* Unchanged on exit. +* +* +* Auxiliary routine for Level 2 Blas. +* +* -- Written on 20-July-1986 +* Richard Hanson, Sandia National Labs. +* Jeremy Du Croz, Nag Central Office. +* +* .. Parameters .. + INTEGER IOFF + PARAMETER ( IOFF=32 ) +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. Executable Statements .. +* +* Test if the characters are equal +* + LSAME = CA .EQ. CB +* +* Now test for equivalence +* + IF ( .NOT.LSAME ) THEN + LSAME = ICHAR(CA) - IOFF .EQ. ICHAR(CB) + END IF +* + RETURN +* +* The following comments contain code for CDC systems using 6-12 bit +* representations. +* +* .. Parameters .. +* INTEGER ICIRFX +* PARAMETER ( ICIRFX=62 ) +* .. Scalar Arguments .. +* CHARACTER*1 CB +* .. Array Arguments .. +* CHARACTER*1 CA(*) +* .. Local Scalars .. +* INTEGER IVAL +* .. Intrinsic Functions .. +* INTRINSIC ICHAR, CHAR +* .. Executable Statements .. +* +* See if the first character in string CA equals string CB. +* +* LSAME = CA(1) .EQ. CB .AND. CA(1) .NE. CHAR(ICIRFX) +* +* IF (LSAME) RETURN +* +* The characters are not identical. Now check them for equivalence. +* Look for the 'escape' character, circumflex, followed by the +* letter. +* +* IVAL = ICHAR(CA(2)) +* IF (IVAL.GE.ICHAR('A') .AND. IVAL.LE.ICHAR('Z')) THEN +* LSAME = CA(1) .EQ. CHAR(ICIRFX) .AND. CA(2) .EQ. CB +* END IF +* +* RETURN +* +* End of LSAME. +* + END +C ---------------- BELOW ARE BLAS-3 ROUTINES ------------- +CUT > DGEMM.F <<'CUT HERE............' +* +************************************************************************ +* +* FILE OF THE DOUBLE PRECISION LEVEL-3 BLAS. +* ========================================== +* +* SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, +* $ BETA, C, LDC ) +* +* SUBROUTINE DSYMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, +* $ BETA, C, LDC ) +* +* SUBROUTINE DSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA, +* $ BETA, C, LDC ) +* +* SUBROUTINE DSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, +* $ BETA, C, LDC ) +* +* SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, +* $ B, LDB ) +* +* SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, +* $ B, LDB ) +* +* SEE: +* +* DONGARRA J. J., DU CROZ J. J., DUFF I. AND HAMMARLING S. +* A SET OF LEVEL 3 BASIC LINEAR ALGEBRA SUBPROGRAMS. TECHNICAL +* MEMORANDUM NO.88 (REVISION 1), MATHEMATICS AND COMPUTER SCIENCE +* DIVISION, ARGONNE NATIONAL LABORATORY, 9700 SOUTH CASS AVENUE, +* ARGONNE, ILLINOIS 60439. +* +* +************************************************************************ +* + SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC ) +* .. SCALAR ARGUMENTS .. + CHARACTER*1 TRANSA, TRANSB + INTEGER M, N, K, LDA, LDB, LDC + DOUBLE PRECISION ALPHA, BETA +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* PURPOSE +* ======= +* +* DGEMM PERFORMS ONE OF THE MATRIX-MATRIX OPERATIONS +* +* C := ALPHA*OP( A )*OP( B ) + BETA*C, +* +* WHERE OP( X ) IS ONE OF +* +* OP( X ) = X OR OP( X ) = X', +* +* ALPHA AND BETA ARE SCALARS, AND A, B AND C ARE MATRICES, WITH OP( A ) +* AN M BY K MATRIX, OP( B ) A K BY N MATRIX AND C AN M BY N MATRIX. +* +* PARAMETERS +* ========== +* +* TRANSA - CHARACTER*1. +* ON ENTRY, TRANSA SPECIFIES THE FORM OF OP( A ) TO BE USED IN +* THE MATRIX MULTIPLICATION AS FOLLOWS: +* +* TRANSA = 'N' OR 'N', OP( A ) = A. +* +* TRANSA = 'T' OR 'T', OP( A ) = A'. +* +* TRANSA = 'C' OR 'C', OP( A ) = A'. +* +* UNCHANGED ON EXIT. +* +* TRANSB - CHARACTER*1. +* ON ENTRY, TRANSB SPECIFIES THE FORM OF OP( B ) TO BE USED IN +* THE MATRIX MULTIPLICATION AS FOLLOWS: +* +* TRANSB = 'N' OR 'N', OP( B ) = B. +* +* TRANSB = 'T' OR 'T', OP( B ) = B'. +* +* TRANSB = 'C' OR 'C', OP( B ) = B'. +* +* UNCHANGED ON EXIT. +* +* M - INTEGER. +* ON ENTRY, M SPECIFIES THE NUMBER OF ROWS OF THE MATRIX +* OP( A ) AND OF THE MATRIX C. M MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE NUMBER OF COLUMNS OF THE MATRIX +* OP( B ) AND THE NUMBER OF COLUMNS OF THE MATRIX C. N MUST BE +* AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* K - INTEGER. +* ON ENTRY, K SPECIFIES THE NUMBER OF COLUMNS OF THE MATRIX +* OP( A ) AND THE NUMBER OF ROWS OF THE MATRIX OP( B ). K MUST +* BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* ALPHA - DOUBLE PRECISION. +* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. +* UNCHANGED ON EXIT. +* +* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, KA ), WHERE KA IS +* K WHEN TRANSA = 'N' OR 'N', AND IS M OTHERWISE. +* BEFORE ENTRY WITH TRANSA = 'N' OR 'N', THE LEADING M BY K +* PART OF THE ARRAY A MUST CONTAIN THE MATRIX A, OTHERWISE +* THE LEADING K BY M PART OF THE ARRAY A MUST CONTAIN THE +* MATRIX A. +* UNCHANGED ON EXIT. +* +* LDA - INTEGER. +* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED +* IN THE CALLING (SUB) PROGRAM. WHEN TRANSA = 'N' OR 'N' THEN +* LDA MUST BE AT LEAST MAX( 1, M ), OTHERWISE LDA MUST BE AT +* LEAST MAX( 1, K ). +* UNCHANGED ON EXIT. +* +* B - DOUBLE PRECISION ARRAY OF DIMENSION ( LDB, KB ), WHERE KB IS +* N WHEN TRANSB = 'N' OR 'N', AND IS K OTHERWISE. +* BEFORE ENTRY WITH TRANSB = 'N' OR 'N', THE LEADING K BY N +* PART OF THE ARRAY B MUST CONTAIN THE MATRIX B, OTHERWISE +* THE LEADING N BY K PART OF THE ARRAY B MUST CONTAIN THE +* MATRIX B. +* UNCHANGED ON EXIT. +* +* LDB - INTEGER. +* ON ENTRY, LDB SPECIFIES THE FIRST DIMENSION OF B AS DECLARED +* IN THE CALLING (SUB) PROGRAM. WHEN TRANSB = 'N' OR 'N' THEN +* LDB MUST BE AT LEAST MAX( 1, K ), OTHERWISE LDB MUST BE AT +* LEAST MAX( 1, N ). +* UNCHANGED ON EXIT. +* +* BETA - DOUBLE PRECISION. +* ON ENTRY, BETA SPECIFIES THE SCALAR BETA. WHEN BETA IS +* SUPPLIED AS ZERO THEN C NEED NOT BE SET ON INPUT. +* UNCHANGED ON EXIT. +* +* C - DOUBLE PRECISION ARRAY OF DIMENSION ( LDC, N ). +* BEFORE ENTRY, THE LEADING M BY N PART OF THE ARRAY C MUST +* CONTAIN THE MATRIX C, EXCEPT WHEN BETA IS ZERO, IN WHICH +* CASE C NEED NOT BE SET ON ENTRY. +* ON EXIT, THE ARRAY C IS OVERWRITTEN BY THE M BY N MATRIX +* ( ALPHA*OP( A )*OP( B ) + BETA*C ). +* +* LDC - INTEGER. +* ON ENTRY, LDC SPECIFIES THE FIRST DIMENSION OF C AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDC MUST BE AT LEAST +* MAX( 1, M ). +* UNCHANGED ON EXIT. +* +* +* LEVEL 3 BLAS ROUTINE. +* +* -- WRITTEN ON 8-FEBRUARY-1989. +* JACK DONGARRA, ARGONNE NATIONAL LABORATORY. +* IAIN DUFF, AERE HARWELL. +* JEREMY DU CROZ, NUMERICAL ALGORITHMS GROUP LTD. +* SVEN HAMMARLING, NUMERICAL ALGORITHMS GROUP LTD. +* +* +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. LOCAL SCALARS .. + LOGICAL NOTA, NOTB + INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB + DOUBLE PRECISION TEMP +* .. PARAMETERS .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. EXECUTABLE STATEMENTS .. +* +* SET NOTA AND NOTB AS TRUE IF A AND B RESPECTIVELY ARE NOT +* TRANSPOSED AND SET NROWA, NCOLA AND NROWB AS THE NUMBER OF ROWS +* AND COLUMNS OF A AND THE NUMBER OF ROWS OF B RESPECTIVELY. +* + NOTA = LSAME( TRANSA, 'N' ) + NOTB = LSAME( TRANSB, 'N' ) + IF( NOTA )THEN + NROWA = M + NCOLA = K + ELSE + NROWA = K + NCOLA = M + END IF + IF( NOTB )THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF( ( .NOT.NOTA ).AND. + $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. + $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.NOTB ).AND. + $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. + $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN + INFO = 2 + ELSE IF( M .LT.0 )THEN + INFO = 3 + ELSE IF( N .LT.0 )THEN + INFO = 4 + ELSE IF( K .LT.0 )THEN + INFO = 5 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 8 + ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN + INFO = 10 + ELSE IF( LDC.LT.MAX( 1, M ) )THEN + INFO = 13 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DGEMM ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* AND IF ALPHA.EQ.ZERO. +* + IF( ALPHA.EQ.ZERO )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, M + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, M + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* START THE OPERATIONS. +* + IF( NOTB )THEN + IF( NOTA )THEN +* +* FORM C := ALPHA*A*B + BETA*C. +* + DO 90, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 50, I = 1, M + C( I, J ) = ZERO + 50 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 60, I = 1, M + C( I, J ) = BETA*C( I, J ) + 60 CONTINUE + END IF + DO 80, L = 1, K + IF( B( L, J ).NE.ZERO )THEN + TEMP = ALPHA*B( L, J ) + DO 70, I = 1, M + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 70 CONTINUE + END IF + 80 CONTINUE + 90 CONTINUE + ELSE +* +* FORM C := ALPHA*A'*B + BETA*C +* + DO 120, J = 1, N + DO 110, I = 1, M + TEMP = ZERO + DO 100, L = 1, K + TEMP = TEMP + A( L, I )*B( L, J ) + 100 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF( NOTA )THEN +* +* FORM C := ALPHA*A*B' + BETA*C +* + DO 170, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 130, I = 1, M + C( I, J ) = ZERO + 130 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 140, I = 1, M + C( I, J ) = BETA*C( I, J ) + 140 CONTINUE + END IF + DO 160, L = 1, K + IF( B( J, L ).NE.ZERO )THEN + TEMP = ALPHA*B( J, L ) + DO 150, I = 1, M + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 150 CONTINUE + END IF + 160 CONTINUE + 170 CONTINUE + ELSE +* +* FORM C := ALPHA*A'*B' + BETA*C +* + DO 200, J = 1, N + DO 190, I = 1, M + TEMP = ZERO + DO 180, L = 1, K + TEMP = TEMP + A( L, I )*B( J, L ) + 180 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* END OF DGEMM . +* + END +CUT HERE............ +CAT > DSYR2K.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC ) +* .. SCALAR ARGUMENTS .. + CHARACTER*1 UPLO, TRANS + INTEGER N, K, LDA, LDB, LDC + DOUBLE PRECISION ALPHA, BETA +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* PURPOSE +* ======= +* +* DSYR2K PERFORMS ONE OF THE SYMMETRIC RANK 2K OPERATIONS +* +* C := ALPHA*A*B' + ALPHA*B*A' + BETA*C, +* +* OR +* +* C := ALPHA*A'*B + ALPHA*B'*A + BETA*C, +* +* WHERE ALPHA AND BETA ARE SCALARS, C IS AN N BY N SYMMETRIC MATRIX +* AND A AND B ARE N BY K MATRICES IN THE FIRST CASE AND K BY N +* MATRICES IN THE SECOND CASE. +* +* PARAMETERS +* ========== +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE UPPER OR LOWER +* TRIANGULAR PART OF THE ARRAY C IS TO BE REFERENCED AS +* FOLLOWS: +* +* UPLO = 'U' OR 'U' ONLY THE UPPER TRIANGULAR PART OF C +* IS TO BE REFERENCED. +* +* UPLO = 'L' OR 'L' ONLY THE LOWER TRIANGULAR PART OF C +* IS TO BE REFERENCED. +* +* UNCHANGED ON EXIT. +* +* TRANS - CHARACTER*1. +* ON ENTRY, TRANS SPECIFIES THE OPERATION TO BE PERFORMED AS +* FOLLOWS: +* +* TRANS = 'N' OR 'N' C := ALPHA*A*B' + ALPHA*B*A' + +* BETA*C. +* +* TRANS = 'T' OR 'T' C := ALPHA*A'*B + ALPHA*B'*A + +* BETA*C. +* +* TRANS = 'C' OR 'C' C := ALPHA*A'*B + ALPHA*B'*A + +* BETA*C. +* +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE ORDER OF THE MATRIX C. N MUST BE +* AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* K - INTEGER. +* ON ENTRY WITH TRANS = 'N' OR 'N', K SPECIFIES THE NUMBER +* OF COLUMNS OF THE MATRICES A AND B, AND ON ENTRY WITH +* TRANS = 'T' OR 'T' OR 'C' OR 'C', K SPECIFIES THE NUMBER +* OF ROWS OF THE MATRICES A AND B. K MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* ALPHA - DOUBLE PRECISION. +* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. +* UNCHANGED ON EXIT. +* +* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, KA ), WHERE KA IS +* K WHEN TRANS = 'N' OR 'N', AND IS N OTHERWISE. +* BEFORE ENTRY WITH TRANS = 'N' OR 'N', THE LEADING N BY K +* PART OF THE ARRAY A MUST CONTAIN THE MATRIX A, OTHERWISE +* THE LEADING K BY N PART OF THE ARRAY A MUST CONTAIN THE +* MATRIX A. +* UNCHANGED ON EXIT. +* +* LDA - INTEGER. +* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED +* IN THE CALLING (SUB) PROGRAM. WHEN TRANS = 'N' OR 'N' +* THEN LDA MUST BE AT LEAST MAX( 1, N ), OTHERWISE LDA MUST +* BE AT LEAST MAX( 1, K ). +* UNCHANGED ON EXIT. +* +* B - DOUBLE PRECISION ARRAY OF DIMENSION ( LDB, KB ), WHERE KB IS +* K WHEN TRANS = 'N' OR 'N', AND IS N OTHERWISE. +* BEFORE ENTRY WITH TRANS = 'N' OR 'N', THE LEADING N BY K +* PART OF THE ARRAY B MUST CONTAIN THE MATRIX B, OTHERWISE +* THE LEADING K BY N PART OF THE ARRAY B MUST CONTAIN THE +* MATRIX B. +* UNCHANGED ON EXIT. +* +* LDB - INTEGER. +* ON ENTRY, LDB SPECIFIES THE FIRST DIMENSION OF B AS DECLARED +* IN THE CALLING (SUB) PROGRAM. WHEN TRANS = 'N' OR 'N' +* THEN LDB MUST BE AT LEAST MAX( 1, N ), OTHERWISE LDB MUST +* BE AT LEAST MAX( 1, K ). +* UNCHANGED ON EXIT. +* +* BETA - DOUBLE PRECISION. +* ON ENTRY, BETA SPECIFIES THE SCALAR BETA. +* UNCHANGED ON EXIT. +* +* C - DOUBLE PRECISION ARRAY OF DIMENSION ( LDC, N ). +* BEFORE ENTRY WITH UPLO = 'U' OR 'U', THE LEADING N BY N +* UPPER TRIANGULAR PART OF THE ARRAY C MUST CONTAIN THE UPPER +* TRIANGULAR PART OF THE SYMMETRIC MATRIX AND THE STRICTLY +* LOWER TRIANGULAR PART OF C IS NOT REFERENCED. ON EXIT, THE +* UPPER TRIANGULAR PART OF THE ARRAY C IS OVERWRITTEN BY THE +* UPPER TRIANGULAR PART OF THE UPDATED MATRIX. +* BEFORE ENTRY WITH UPLO = 'L' OR 'L', THE LEADING N BY N +* LOWER TRIANGULAR PART OF THE ARRAY C MUST CONTAIN THE LOWER +* TRIANGULAR PART OF THE SYMMETRIC MATRIX AND THE STRICTLY +* UPPER TRIANGULAR PART OF C IS NOT REFERENCED. ON EXIT, THE +* LOWER TRIANGULAR PART OF THE ARRAY C IS OVERWRITTEN BY THE +* LOWER TRIANGULAR PART OF THE UPDATED MATRIX. +* +* LDC - INTEGER. +* ON ENTRY, LDC SPECIFIES THE FIRST DIMENSION OF C AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDC MUST BE AT LEAST +* MAX( 1, N ). +* UNCHANGED ON EXIT. +* +* +* LEVEL 3 BLAS ROUTINE. +* +* +* -- WRITTEN ON 8-FEBRUARY-1989. +* JACK DONGARRA, ARGONNE NATIONAL LABORATORY. +* IAIN DUFF, AERE HARWELL. +* JEREMY DU CROZ, NUMERICAL ALGORITHMS GROUP LTD. +* SVEN HAMMARLING, NUMERICAL ALGORITHMS GROUP LTD. +* +* +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. LOCAL SCALARS .. + LOGICAL UPPER + INTEGER I, INFO, J, L, NROWA + DOUBLE PRECISION TEMP1, TEMP2 +* .. PARAMETERS .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + IF( LSAME( TRANS, 'N' ) )THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME( UPLO, 'U' ) +* + INFO = 0 + IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN + INFO = 2 + ELSE IF( N .LT.0 )THEN + INFO = 3 + ELSE IF( K .LT.0 )THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 7 + ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN + INFO = 9 + ELSE IF( LDC.LT.MAX( 1, N ) )THEN + INFO = 12 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYR2K', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( ( N.EQ.0 ).OR. + $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* AND WHEN ALPHA.EQ.ZERO. +* + IF( ALPHA.EQ.ZERO )THEN + IF( UPPER )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, J + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, J + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF( BETA.EQ.ZERO )THEN + DO 60, J = 1, N + DO 50, I = J, N + C( I, J ) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80, J = 1, N + DO 70, I = J, N + C( I, J ) = BETA*C( I, J ) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* START THE OPERATIONS. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* FORM C := ALPHA*A*B' + ALPHA*B*A' + C. +* + IF( UPPER )THEN + DO 130, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 90, I = 1, J + C( I, J ) = ZERO + 90 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 100, I = 1, J + C( I, J ) = BETA*C( I, J ) + 100 CONTINUE + END IF + DO 120, L = 1, K + IF( ( A( J, L ).NE.ZERO ).OR. + $ ( B( J, L ).NE.ZERO ) )THEN + TEMP1 = ALPHA*B( J, L ) + TEMP2 = ALPHA*A( J, L ) + DO 110, I = 1, J + C( I, J ) = C( I, J ) + + $ A( I, L )*TEMP1 + B( I, L )*TEMP2 + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 140, I = J, N + C( I, J ) = ZERO + 140 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 150, I = J, N + C( I, J ) = BETA*C( I, J ) + 150 CONTINUE + END IF + DO 170, L = 1, K + IF( ( A( J, L ).NE.ZERO ).OR. + $ ( B( J, L ).NE.ZERO ) )THEN + TEMP1 = ALPHA*B( J, L ) + TEMP2 = ALPHA*A( J, L ) + DO 160, I = J, N + C( I, J ) = C( I, J ) + + $ A( I, L )*TEMP1 + B( I, L )*TEMP2 + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* FORM C := ALPHA*A'*B + ALPHA*B'*A + C. +* + IF( UPPER )THEN + DO 210, J = 1, N + DO 200, I = 1, J + TEMP1 = ZERO + TEMP2 = ZERO + DO 190, L = 1, K + TEMP1 = TEMP1 + A( L, I )*B( L, J ) + TEMP2 = TEMP2 + B( L, I )*A( L, J ) + 190 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C( I, J ) = BETA *C( I, J ) + + $ ALPHA*TEMP1 + ALPHA*TEMP2 + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240, J = 1, N + DO 230, I = J, N + TEMP1 = ZERO + TEMP2 = ZERO + DO 220, L = 1, K + TEMP1 = TEMP1 + A( L, I )*B( L, J ) + TEMP2 = TEMP2 + B( L, I )*A( L, J ) + 220 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 + ELSE + C( I, J ) = BETA *C( I, J ) + + $ ALPHA*TEMP1 + ALPHA*TEMP2 + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* END OF DSYR2K. +* + END +CUT HERE............ +CAT > DSYRK.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA, + $ BETA, C, LDC ) +* .. SCALAR ARGUMENTS .. + CHARACTER*1 UPLO, TRANS + INTEGER N, K, LDA, LDC + DOUBLE PRECISION ALPHA, BETA +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ) +* .. +* +* PURPOSE +* ======= +* +* DSYRK PERFORMS ONE OF THE SYMMETRIC RANK K OPERATIONS +* +* C := ALPHA*A*A' + BETA*C, +* +* OR +* +* C := ALPHA*A'*A + BETA*C, +* +* WHERE ALPHA AND BETA ARE SCALARS, C IS AN N BY N SYMMETRIC MATRIX +* AND A IS AN N BY K MATRIX IN THE FIRST CASE AND A K BY N MATRIX +* IN THE SECOND CASE. +* +* PARAMETERS +* ========== +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE UPPER OR LOWER +* TRIANGULAR PART OF THE ARRAY C IS TO BE REFERENCED AS +* FOLLOWS: +* +* UPLO = 'U' OR 'U' ONLY THE UPPER TRIANGULAR PART OF C +* IS TO BE REFERENCED. +* +* UPLO = 'L' OR 'L' ONLY THE LOWER TRIANGULAR PART OF C +* IS TO BE REFERENCED. +* +* UNCHANGED ON EXIT. +* +* TRANS - CHARACTER*1. +* ON ENTRY, TRANS SPECIFIES THE OPERATION TO BE PERFORMED AS +* FOLLOWS: +* +* TRANS = 'N' OR 'N' C := ALPHA*A*A' + BETA*C. +* +* TRANS = 'T' OR 'T' C := ALPHA*A'*A + BETA*C. +* +* TRANS = 'C' OR 'C' C := ALPHA*A'*A + BETA*C. +* +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE ORDER OF THE MATRIX C. N MUST BE +* AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* K - INTEGER. +* ON ENTRY WITH TRANS = 'N' OR 'N', K SPECIFIES THE NUMBER +* OF COLUMNS OF THE MATRIX A, AND ON ENTRY WITH +* TRANS = 'T' OR 'T' OR 'C' OR 'C', K SPECIFIES THE NUMBER +* OF ROWS OF THE MATRIX A. K MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* ALPHA - DOUBLE PRECISION. +* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. +* UNCHANGED ON EXIT. +* +* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, KA ), WHERE KA IS +* K WHEN TRANS = 'N' OR 'N', AND IS N OTHERWISE. +* BEFORE ENTRY WITH TRANS = 'N' OR 'N', THE LEADING N BY K +* PART OF THE ARRAY A MUST CONTAIN THE MATRIX A, OTHERWISE +* THE LEADING K BY N PART OF THE ARRAY A MUST CONTAIN THE +* MATRIX A. +* UNCHANGED ON EXIT. +* +* LDA - INTEGER. +* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED +* IN THE CALLING (SUB) PROGRAM. WHEN TRANS = 'N' OR 'N' +* THEN LDA MUST BE AT LEAST MAX( 1, N ), OTHERWISE LDA MUST +* BE AT LEAST MAX( 1, K ). +* UNCHANGED ON EXIT. +* +* BETA - DOUBLE PRECISION. +* ON ENTRY, BETA SPECIFIES THE SCALAR BETA. +* UNCHANGED ON EXIT. +* +* C - DOUBLE PRECISION ARRAY OF DIMENSION ( LDC, N ). +* BEFORE ENTRY WITH UPLO = 'U' OR 'U', THE LEADING N BY N +* UPPER TRIANGULAR PART OF THE ARRAY C MUST CONTAIN THE UPPER +* TRIANGULAR PART OF THE SYMMETRIC MATRIX AND THE STRICTLY +* LOWER TRIANGULAR PART OF C IS NOT REFERENCED. ON EXIT, THE +* UPPER TRIANGULAR PART OF THE ARRAY C IS OVERWRITTEN BY THE +* UPPER TRIANGULAR PART OF THE UPDATED MATRIX. +* BEFORE ENTRY WITH UPLO = 'L' OR 'L', THE LEADING N BY N +* LOWER TRIANGULAR PART OF THE ARRAY C MUST CONTAIN THE LOWER +* TRIANGULAR PART OF THE SYMMETRIC MATRIX AND THE STRICTLY +* UPPER TRIANGULAR PART OF C IS NOT REFERENCED. ON EXIT, THE +* LOWER TRIANGULAR PART OF THE ARRAY C IS OVERWRITTEN BY THE +* LOWER TRIANGULAR PART OF THE UPDATED MATRIX. +* +* LDC - INTEGER. +* ON ENTRY, LDC SPECIFIES THE FIRST DIMENSION OF C AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDC MUST BE AT LEAST +* MAX( 1, N ). +* UNCHANGED ON EXIT. +* +* +* LEVEL 3 BLAS ROUTINE. +* +* -- WRITTEN ON 8-FEBRUARY-1989. +* JACK DONGARRA, ARGONNE NATIONAL LABORATORY. +* IAIN DUFF, AERE HARWELL. +* JEREMY DU CROZ, NUMERICAL ALGORITHMS GROUP LTD. +* SVEN HAMMARLING, NUMERICAL ALGORITHMS GROUP LTD. +* +* +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. LOCAL SCALARS .. + LOGICAL UPPER + INTEGER I, INFO, J, L, NROWA + DOUBLE PRECISION TEMP +* .. PARAMETERS .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + IF( LSAME( TRANS, 'N' ) )THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME( UPLO, 'U' ) +* + INFO = 0 + IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN + INFO = 2 + ELSE IF( N .LT.0 )THEN + INFO = 3 + ELSE IF( K .LT.0 )THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 7 + ELSE IF( LDC.LT.MAX( 1, N ) )THEN + INFO = 10 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYRK ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( ( N.EQ.0 ).OR. + $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* AND WHEN ALPHA.EQ.ZERO. +* + IF( ALPHA.EQ.ZERO )THEN + IF( UPPER )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, J + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, J + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF( BETA.EQ.ZERO )THEN + DO 60, J = 1, N + DO 50, I = J, N + C( I, J ) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80, J = 1, N + DO 70, I = J, N + C( I, J ) = BETA*C( I, J ) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* START THE OPERATIONS. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* FORM C := ALPHA*A*A' + BETA*C. +* + IF( UPPER )THEN + DO 130, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 90, I = 1, J + C( I, J ) = ZERO + 90 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 100, I = 1, J + C( I, J ) = BETA*C( I, J ) + 100 CONTINUE + END IF + DO 120, L = 1, K + IF( A( J, L ).NE.ZERO )THEN + TEMP = ALPHA*A( J, L ) + DO 110, I = 1, J + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 140, I = J, N + C( I, J ) = ZERO + 140 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 150, I = J, N + C( I, J ) = BETA*C( I, J ) + 150 CONTINUE + END IF + DO 170, L = 1, K + IF( A( J, L ).NE.ZERO )THEN + TEMP = ALPHA*A( J, L ) + DO 160, I = J, N + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* FORM C := ALPHA*A'*A + BETA*C. +* + IF( UPPER )THEN + DO 210, J = 1, N + DO 200, I = 1, J + TEMP = ZERO + DO 190, L = 1, K + TEMP = TEMP + A( L, I )*A( L, J ) + 190 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240, J = 1, N + DO 230, I = J, N + TEMP = ZERO + DO 220, L = 1, K + TEMP = TEMP + A( L, I )*A( L, J ) + 220 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* END OF DSYRK . +* + END +CUT HERE............ +CAT > DSYMM.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DSYMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC ) +* .. SCALAR ARGUMENTS .. + CHARACTER*1 SIDE, UPLO + INTEGER M, N, LDA, LDB, LDC + DOUBLE PRECISION ALPHA, BETA +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* PURPOSE +* ======= +* +* DSYMM PERFORMS ONE OF THE MATRIX-MATRIX OPERATIONS +* +* C := ALPHA*A*B + BETA*C, +* +* OR +* +* C := ALPHA*B*A + BETA*C, +* +* WHERE ALPHA AND BETA ARE SCALARS, A IS A SYMMETRIC MATRIX AND B AND +* C ARE M BY N MATRICES. +* +* PARAMETERS +* ========== +* +* SIDE - CHARACTER*1. +* ON ENTRY, SIDE SPECIFIES WHETHER THE SYMMETRIC MATRIX A +* APPEARS ON THE LEFT OR RIGHT IN THE OPERATION AS FOLLOWS: +* +* SIDE = 'L' OR 'L' C := ALPHA*A*B + BETA*C, +* +* SIDE = 'R' OR 'R' C := ALPHA*B*A + BETA*C, +* +* UNCHANGED ON EXIT. +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE UPPER OR LOWER +* TRIANGULAR PART OF THE SYMMETRIC MATRIX A IS TO BE +* REFERENCED AS FOLLOWS: +* +* UPLO = 'U' OR 'U' ONLY THE UPPER TRIANGULAR PART OF THE +* SYMMETRIC MATRIX IS TO BE REFERENCED. +* +* UPLO = 'L' OR 'L' ONLY THE LOWER TRIANGULAR PART OF THE +* SYMMETRIC MATRIX IS TO BE REFERENCED. +* +* UNCHANGED ON EXIT. +* +* M - INTEGER. +* ON ENTRY, M SPECIFIES THE NUMBER OF ROWS OF THE MATRIX C. +* M MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE NUMBER OF COLUMNS OF THE MATRIX C. +* N MUST BE AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* ALPHA - DOUBLE PRECISION. +* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. +* UNCHANGED ON EXIT. +* +* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, KA ), WHERE KA IS +* M WHEN SIDE = 'L' OR 'L' AND IS N OTHERWISE. +* BEFORE ENTRY WITH SIDE = 'L' OR 'L', THE M BY M PART OF +* THE ARRAY A MUST CONTAIN THE SYMMETRIC MATRIX, SUCH THAT +* WHEN UPLO = 'U' OR 'U', THE LEADING M BY M UPPER TRIANGULAR +* PART OF THE ARRAY A MUST CONTAIN THE UPPER TRIANGULAR PART +* OF THE SYMMETRIC MATRIX AND THE STRICTLY LOWER TRIANGULAR +* PART OF A IS NOT REFERENCED, AND WHEN UPLO = 'L' OR 'L', +* THE LEADING M BY M LOWER TRIANGULAR PART OF THE ARRAY A +* MUST CONTAIN THE LOWER TRIANGULAR PART OF THE SYMMETRIC +* MATRIX AND THE STRICTLY UPPER TRIANGULAR PART OF A IS NOT +* REFERENCED. +* BEFORE ENTRY WITH SIDE = 'R' OR 'R', THE N BY N PART OF +* THE ARRAY A MUST CONTAIN THE SYMMETRIC MATRIX, SUCH THAT +* WHEN UPLO = 'U' OR 'U', THE LEADING N BY N UPPER TRIANGULAR +* PART OF THE ARRAY A MUST CONTAIN THE UPPER TRIANGULAR PART +* OF THE SYMMETRIC MATRIX AND THE STRICTLY LOWER TRIANGULAR +* PART OF A IS NOT REFERENCED, AND WHEN UPLO = 'L' OR 'L', +* THE LEADING N BY N LOWER TRIANGULAR PART OF THE ARRAY A +* MUST CONTAIN THE LOWER TRIANGULAR PART OF THE SYMMETRIC +* MATRIX AND THE STRICTLY UPPER TRIANGULAR PART OF A IS NOT +* REFERENCED. +* UNCHANGED ON EXIT. +* +* LDA - INTEGER. +* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED +* IN THE CALLING (SUB) PROGRAM. WHEN SIDE = 'L' OR 'L' THEN +* LDA MUST BE AT LEAST MAX( 1, M ), OTHERWISE LDA MUST BE AT +* LEAST MAX( 1, N ). +* UNCHANGED ON EXIT. +* +* B - DOUBLE PRECISION ARRAY OF DIMENSION ( LDB, N ). +* BEFORE ENTRY, THE LEADING M BY N PART OF THE ARRAY B MUST +* CONTAIN THE MATRIX B. +* UNCHANGED ON EXIT. +* +* LDB - INTEGER. +* ON ENTRY, LDB SPECIFIES THE FIRST DIMENSION OF B AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDB MUST BE AT LEAST +* MAX( 1, M ). +* UNCHANGED ON EXIT. +* +* BETA - DOUBLE PRECISION. +* ON ENTRY, BETA SPECIFIES THE SCALAR BETA. WHEN BETA IS +* SUPPLIED AS ZERO THEN C NEED NOT BE SET ON INPUT. +* UNCHANGED ON EXIT. +* +* C - DOUBLE PRECISION ARRAY OF DIMENSION ( LDC, N ). +* BEFORE ENTRY, THE LEADING M BY N PART OF THE ARRAY C MUST +* CONTAIN THE MATRIX C, EXCEPT WHEN BETA IS ZERO, IN WHICH +* CASE C NEED NOT BE SET ON ENTRY. +* ON EXIT, THE ARRAY C IS OVERWRITTEN BY THE M BY N UPDATED +* MATRIX. +* +* LDC - INTEGER. +* ON ENTRY, LDC SPECIFIES THE FIRST DIMENSION OF C AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDC MUST BE AT LEAST +* MAX( 1, M ). +* UNCHANGED ON EXIT. +* +* +* LEVEL 3 BLAS ROUTINE. +* +* -- WRITTEN ON 8-FEBRUARY-1989. +* JACK DONGARRA, ARGONNE NATIONAL LABORATORY. +* IAIN DUFF, AERE HARWELL. +* JEREMY DU CROZ, NUMERICAL ALGORITHMS GROUP LTD. +* SVEN HAMMARLING, NUMERICAL ALGORITHMS GROUP LTD. +* +* +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. LOCAL SCALARS .. + LOGICAL UPPER + INTEGER I, INFO, J, K, NROWA + DOUBLE PRECISION TEMP1, TEMP2 +* .. PARAMETERS .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. EXECUTABLE STATEMENTS .. +* +* SET NROWA AS THE NUMBER OF ROWS OF A. +* + IF( LSAME( SIDE, 'L' ) )THEN + NROWA = M + ELSE + NROWA = N + END IF + UPPER = LSAME( UPLO, 'U' ) +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. + $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN + INFO = 2 + ELSE IF( M .LT.0 )THEN + INFO = 3 + ELSE IF( N .LT.0 )THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 7 + ELSE IF( LDB.LT.MAX( 1, M ) )THEN + INFO = 9 + ELSE IF( LDC.LT.MAX( 1, M ) )THEN + INFO = 12 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYMM ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* AND WHEN ALPHA.EQ.ZERO. +* + IF( ALPHA.EQ.ZERO )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, M + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, M + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* START THE OPERATIONS. +* + IF( LSAME( SIDE, 'L' ) )THEN +* +* FORM C := ALPHA*A*B + BETA*C. +* + IF( UPPER )THEN + DO 70, J = 1, N + DO 60, I = 1, M + TEMP1 = ALPHA*B( I, J ) + TEMP2 = ZERO + DO 50, K = 1, I - 1 + C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) + TEMP2 = TEMP2 + B( K, J )*A( K, I ) + 50 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 + ELSE + C( I, J ) = BETA *C( I, J ) + + $ TEMP1*A( I, I ) + ALPHA*TEMP2 + END IF + 60 CONTINUE + 70 CONTINUE + ELSE + DO 100, J = 1, N + DO 90, I = M, 1, -1 + TEMP1 = ALPHA*B( I, J ) + TEMP2 = ZERO + DO 80, K = I + 1, M + C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) + TEMP2 = TEMP2 + B( K, J )*A( K, I ) + 80 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 + ELSE + C( I, J ) = BETA *C( I, J ) + + $ TEMP1*A( I, I ) + ALPHA*TEMP2 + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* FORM C := ALPHA*B*A + BETA*C. +* + DO 170, J = 1, N + TEMP1 = ALPHA*A( J, J ) + IF( BETA.EQ.ZERO )THEN + DO 110, I = 1, M + C( I, J ) = TEMP1*B( I, J ) + 110 CONTINUE + ELSE + DO 120, I = 1, M + C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) + 120 CONTINUE + END IF + DO 140, K = 1, J - 1 + IF( UPPER )THEN + TEMP1 = ALPHA*A( K, J ) + ELSE + TEMP1 = ALPHA*A( J, K ) + END IF + DO 130, I = 1, M + C( I, J ) = C( I, J ) + TEMP1*B( I, K ) + 130 CONTINUE + 140 CONTINUE + DO 160, K = J + 1, N + IF( UPPER )THEN + TEMP1 = ALPHA*A( J, K ) + ELSE + TEMP1 = ALPHA*A( K, J ) + END IF + DO 150, I = 1, M + C( I, J ) = C( I, J ) + TEMP1*B( I, K ) + 150 CONTINUE + 160 CONTINUE + 170 CONTINUE + END IF +* + RETURN +* +* END OF DSYMM . +* + END +CUT HERE............ +CAT > DTRSM.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, + $ B, LDB ) +* .. SCALAR ARGUMENTS .. + CHARACTER*1 SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + DOUBLE PRECISION ALPHA +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* PURPOSE +* ======= +* +* DTRSM SOLVES ONE OF THE MATRIX EQUATIONS +* +* OP( A )*X = ALPHA*B, OR X*OP( A ) = ALPHA*B, +* +* WHERE ALPHA IS A SCALAR, X AND B ARE M BY N MATRICES, A IS A UNIT, OR +* NON-UNIT, UPPER OR LOWER TRIANGULAR MATRIX AND OP( A ) IS ONE OF +* +* OP( A ) = A OR OP( A ) = A'. +* +* THE MATRIX X IS OVERWRITTEN ON B. +* +* PARAMETERS +* ========== +* +* SIDE - CHARACTER*1. +* ON ENTRY, SIDE SPECIFIES WHETHER OP( A ) APPEARS ON THE LEFT +* OR RIGHT OF X AS FOLLOWS: +* +* SIDE = 'L' OR 'L' OP( A )*X = ALPHA*B. +* +* SIDE = 'R' OR 'R' X*OP( A ) = ALPHA*B. +* +* UNCHANGED ON EXIT. +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE MATRIX A IS AN UPPER OR +* LOWER TRIANGULAR MATRIX AS FOLLOWS: +* +* UPLO = 'U' OR 'U' A IS AN UPPER TRIANGULAR MATRIX. +* +* UPLO = 'L' OR 'L' A IS A LOWER TRIANGULAR MATRIX. +* +* UNCHANGED ON EXIT. +* +* TRANSA - CHARACTER*1. +* ON ENTRY, TRANSA SPECIFIES THE FORM OF OP( A ) TO BE USED IN +* THE MATRIX MULTIPLICATION AS FOLLOWS: +* +* TRANSA = 'N' OR 'N' OP( A ) = A. +* +* TRANSA = 'T' OR 'T' OP( A ) = A'. +* +* TRANSA = 'C' OR 'C' OP( A ) = A'. +* +* UNCHANGED ON EXIT. +* +* DIAG - CHARACTER*1. +* ON ENTRY, DIAG SPECIFIES WHETHER OR NOT A IS UNIT TRIANGULAR +* AS FOLLOWS: +* +* DIAG = 'U' OR 'U' A IS ASSUMED TO BE UNIT TRIANGULAR. +* +* DIAG = 'N' OR 'N' A IS NOT ASSUMED TO BE UNIT +* TRIANGULAR. +* +* UNCHANGED ON EXIT. +* +* M - INTEGER. +* ON ENTRY, M SPECIFIES THE NUMBER OF ROWS OF B. M MUST BE AT +* LEAST ZERO. +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE NUMBER OF COLUMNS OF B. N MUST BE +* AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* ALPHA - DOUBLE PRECISION. +* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. WHEN ALPHA IS +* ZERO THEN A IS NOT REFERENCED AND B NEED NOT BE SET BEFORE +* ENTRY. +* UNCHANGED ON EXIT. +* +* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, K ), WHERE K IS M +* WHEN SIDE = 'L' OR 'L' AND IS N WHEN SIDE = 'R' OR 'R'. +* BEFORE ENTRY WITH UPLO = 'U' OR 'U', THE LEADING K BY K +* UPPER TRIANGULAR PART OF THE ARRAY A MUST CONTAIN THE UPPER +* TRIANGULAR MATRIX AND THE STRICTLY LOWER TRIANGULAR PART OF +* A IS NOT REFERENCED. +* BEFORE ENTRY WITH UPLO = 'L' OR 'L', THE LEADING K BY K +* LOWER TRIANGULAR PART OF THE ARRAY A MUST CONTAIN THE LOWER +* TRIANGULAR MATRIX AND THE STRICTLY UPPER TRIANGULAR PART OF +* A IS NOT REFERENCED. +* NOTE THAT WHEN DIAG = 'U' OR 'U', THE DIAGONAL ELEMENTS OF +* A ARE NOT REFERENCED EITHER, BUT ARE ASSUMED TO BE UNITY. +* UNCHANGED ON EXIT. +* +* LDA - INTEGER. +* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED +* IN THE CALLING (SUB) PROGRAM. WHEN SIDE = 'L' OR 'L' THEN +* LDA MUST BE AT LEAST MAX( 1, M ), WHEN SIDE = 'R' OR 'R' +* THEN LDA MUST BE AT LEAST MAX( 1, N ). +* UNCHANGED ON EXIT. +* +* B - DOUBLE PRECISION ARRAY OF DIMENSION ( LDB, N ). +* BEFORE ENTRY, THE LEADING M BY N PART OF THE ARRAY B MUST +* CONTAIN THE RIGHT-HAND SIDE MATRIX B, AND ON EXIT IS +* OVERWRITTEN BY THE SOLUTION MATRIX X. +* +* LDB - INTEGER. +* ON ENTRY, LDB SPECIFIES THE FIRST DIMENSION OF B AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDB MUST BE AT LEAST +* MAX( 1, M ). +* UNCHANGED ON EXIT. +* +* +* LEVEL 3 BLAS ROUTINE. +* +* +* -- WRITTEN ON 8-FEBRUARY-1989. +* JACK DONGARRA, ARGONNE NATIONAL LABORATORY. +* IAIN DUFF, AERE HARWELL. +* JEREMY DU CROZ, NUMERICAL ALGORITHMS GROUP LTD. +* SVEN HAMMARLING, NUMERICAL ALGORITHMS GROUP LTD. +* +* +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. LOCAL SCALARS .. + LOGICAL LSIDE, NOUNIT, UPPER + INTEGER I, INFO, J, K, NROWA + DOUBLE PRECISION TEMP +* .. PARAMETERS .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + LSIDE = LSAME( SIDE , 'L' ) + IF( LSIDE )THEN + NROWA = M + ELSE + NROWA = N + END IF + NOUNIT = LSAME( DIAG , 'N' ) + UPPER = LSAME( UPLO , 'U' ) +* + INFO = 0 + IF( ( .NOT.LSIDE ).AND. + $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN + INFO = 2 + ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. + $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. + $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN + INFO = 3 + ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. + $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN + INFO = 4 + ELSE IF( M .LT.0 )THEN + INFO = 5 + ELSE IF( N .LT.0 )THEN + INFO = 6 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 9 + ELSE IF( LDB.LT.MAX( 1, M ) )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DTRSM ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( N.EQ.0 ) + $ RETURN +* +* AND WHEN ALPHA.EQ.ZERO. +* + IF( ALPHA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, M + B( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* START THE OPERATIONS. +* + IF( LSIDE )THEN + IF( LSAME( TRANSA, 'N' ) )THEN +* +* FORM B := ALPHA*INV( A )*B. +* + IF( UPPER )THEN + DO 60, J = 1, N + IF( ALPHA.NE.ONE )THEN + DO 30, I = 1, M + B( I, J ) = ALPHA*B( I, J ) + 30 CONTINUE + END IF + DO 50, K = M, 1, -1 + IF( B( K, J ).NE.ZERO )THEN + IF( NOUNIT ) + $ B( K, J ) = B( K, J )/A( K, K ) + DO 40, I = 1, K - 1 + B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) + 40 CONTINUE + END IF + 50 CONTINUE + 60 CONTINUE + ELSE + DO 100, J = 1, N + IF( ALPHA.NE.ONE )THEN + DO 70, I = 1, M + B( I, J ) = ALPHA*B( I, J ) + 70 CONTINUE + END IF + DO 90 K = 1, M + IF( B( K, J ).NE.ZERO )THEN + IF( NOUNIT ) + $ B( K, J ) = B( K, J )/A( K, K ) + DO 80, I = K + 1, M + B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) + 80 CONTINUE + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* FORM B := ALPHA*INV( A' )*B. +* + IF( UPPER )THEN + DO 130, J = 1, N + DO 120, I = 1, M + TEMP = ALPHA*B( I, J ) + DO 110, K = 1, I - 1 + TEMP = TEMP - A( K, I )*B( K, J ) + 110 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( I, I ) + B( I, J ) = TEMP + 120 CONTINUE + 130 CONTINUE + ELSE + DO 160, J = 1, N + DO 150, I = M, 1, -1 + TEMP = ALPHA*B( I, J ) + DO 140, K = I + 1, M + TEMP = TEMP - A( K, I )*B( K, J ) + 140 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( I, I ) + B( I, J ) = TEMP + 150 CONTINUE + 160 CONTINUE + END IF + END IF + ELSE + IF( LSAME( TRANSA, 'N' ) )THEN +* +* FORM B := ALPHA*B*INV( A ). +* + IF( UPPER )THEN + DO 210, J = 1, N + IF( ALPHA.NE.ONE )THEN + DO 170, I = 1, M + B( I, J ) = ALPHA*B( I, J ) + 170 CONTINUE + END IF + DO 190, K = 1, J - 1 + IF( A( K, J ).NE.ZERO )THEN + DO 180, I = 1, M + B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) + 180 CONTINUE + END IF + 190 CONTINUE + IF( NOUNIT )THEN + TEMP = ONE/A( J, J ) + DO 200, I = 1, M + B( I, J ) = TEMP*B( I, J ) + 200 CONTINUE + END IF + 210 CONTINUE + ELSE + DO 260, J = N, 1, -1 + IF( ALPHA.NE.ONE )THEN + DO 220, I = 1, M + B( I, J ) = ALPHA*B( I, J ) + 220 CONTINUE + END IF + DO 240, K = J + 1, N + IF( A( K, J ).NE.ZERO )THEN + DO 230, I = 1, M + B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) + 230 CONTINUE + END IF + 240 CONTINUE + IF( NOUNIT )THEN + TEMP = ONE/A( J, J ) + DO 250, I = 1, M + B( I, J ) = TEMP*B( I, J ) + 250 CONTINUE + END IF + 260 CONTINUE + END IF + ELSE +* +* FORM B := ALPHA*B*INV( A' ). +* + IF( UPPER )THEN + DO 310, K = N, 1, -1 + IF( NOUNIT )THEN + TEMP = ONE/A( K, K ) + DO 270, I = 1, M + B( I, K ) = TEMP*B( I, K ) + 270 CONTINUE + END IF + DO 290, J = 1, K - 1 + IF( A( J, K ).NE.ZERO )THEN + TEMP = A( J, K ) + DO 280, I = 1, M + B( I, J ) = B( I, J ) - TEMP*B( I, K ) + 280 CONTINUE + END IF + 290 CONTINUE + IF( ALPHA.NE.ONE )THEN + DO 300, I = 1, M + B( I, K ) = ALPHA*B( I, K ) + 300 CONTINUE + END IF + 310 CONTINUE + ELSE + DO 360, K = 1, N + IF( NOUNIT )THEN + TEMP = ONE/A( K, K ) + DO 320, I = 1, M + B( I, K ) = TEMP*B( I, K ) + 320 CONTINUE + END IF + DO 340, J = K + 1, N + IF( A( J, K ).NE.ZERO )THEN + TEMP = A( J, K ) + DO 330, I = 1, M + B( I, J ) = B( I, J ) - TEMP*B( I, K ) + 330 CONTINUE + END IF + 340 CONTINUE + IF( ALPHA.NE.ONE )THEN + DO 350, I = 1, M + B( I, K ) = ALPHA*B( I, K ) + 350 CONTINUE + END IF + 360 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* END OF DTRSM . +* + END +CUT HERE............ +CAT > DTRMM.F <<'CUT HERE............' +* +************************************************************************ +* + SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, + $ B, LDB ) +* .. SCALAR ARGUMENTS .. + CHARACTER*1 SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + DOUBLE PRECISION ALPHA +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* PURPOSE +* ======= +* +* DTRMM PERFORMS ONE OF THE MATRIX-MATRIX OPERATIONS +* +* B := ALPHA*OP( A )*B, OR B := ALPHA*B*OP( A ), +* +* WHERE ALPHA IS A SCALAR, B IS AN M BY N MATRIX, A IS A UNIT, OR +* NON-UNIT, UPPER OR LOWER TRIANGULAR MATRIX AND OP( A ) IS ONE OF +* +* OP( A ) = A OR OP( A ) = A'. +* +* PARAMETERS +* ========== +* +* SIDE - CHARACTER*1. +* ON ENTRY, SIDE SPECIFIES WHETHER OP( A ) MULTIPLIES B FROM +* THE LEFT OR RIGHT AS FOLLOWS: +* +* SIDE = 'L' OR 'L' B := ALPHA*OP( A )*B. +* +* SIDE = 'R' OR 'R' B := ALPHA*B*OP( A ). +* +* UNCHANGED ON EXIT. +* +* UPLO - CHARACTER*1. +* ON ENTRY, UPLO SPECIFIES WHETHER THE MATRIX A IS AN UPPER OR +* LOWER TRIANGULAR MATRIX AS FOLLOWS: +* +* UPLO = 'U' OR 'U' A IS AN UPPER TRIANGULAR MATRIX. +* +* UPLO = 'L' OR 'L' A IS A LOWER TRIANGULAR MATRIX. +* +* UNCHANGED ON EXIT. +* +* TRANSA - CHARACTER*1. +* ON ENTRY, TRANSA SPECIFIES THE FORM OF OP( A ) TO BE USED IN +* THE MATRIX MULTIPLICATION AS FOLLOWS: +* +* TRANSA = 'N' OR 'N' OP( A ) = A. +* +* TRANSA = 'T' OR 'T' OP( A ) = A'. +* +* TRANSA = 'C' OR 'C' OP( A ) = A'. +* +* UNCHANGED ON EXIT. +* +* DIAG - CHARACTER*1. +* ON ENTRY, DIAG SPECIFIES WHETHER OR NOT A IS UNIT TRIANGULAR +* AS FOLLOWS: +* +* DIAG = 'U' OR 'U' A IS ASSUMED TO BE UNIT TRIANGULAR. +* +* DIAG = 'N' OR 'N' A IS NOT ASSUMED TO BE UNIT +* TRIANGULAR. +* +* UNCHANGED ON EXIT. +* +* M - INTEGER. +* ON ENTRY, M SPECIFIES THE NUMBER OF ROWS OF B. M MUST BE AT +* LEAST ZERO. +* UNCHANGED ON EXIT. +* +* N - INTEGER. +* ON ENTRY, N SPECIFIES THE NUMBER OF COLUMNS OF B. N MUST BE +* AT LEAST ZERO. +* UNCHANGED ON EXIT. +* +* ALPHA - DOUBLE PRECISION. +* ON ENTRY, ALPHA SPECIFIES THE SCALAR ALPHA. WHEN ALPHA IS +* ZERO THEN A IS NOT REFERENCED AND B NEED NOT BE SET BEFORE +* ENTRY. +* UNCHANGED ON EXIT. +* +* A - DOUBLE PRECISION ARRAY OF DIMENSION ( LDA, K ), WHERE K IS M +* WHEN SIDE = 'L' OR 'L' AND IS N WHEN SIDE = 'R' OR 'R'. +* BEFORE ENTRY WITH UPLO = 'U' OR 'U', THE LEADING K BY K +* UPPER TRIANGULAR PART OF THE ARRAY A MUST CONTAIN THE UPPER +* TRIANGULAR MATRIX AND THE STRICTLY LOWER TRIANGULAR PART OF +* A IS NOT REFERENCED. +* BEFORE ENTRY WITH UPLO = 'L' OR 'L', THE LEADING K BY K +* LOWER TRIANGULAR PART OF THE ARRAY A MUST CONTAIN THE LOWER +* TRIANGULAR MATRIX AND THE STRICTLY UPPER TRIANGULAR PART OF +* A IS NOT REFERENCED. +* NOTE THAT WHEN DIAG = 'U' OR 'U', THE DIAGONAL ELEMENTS OF +* A ARE NOT REFERENCED EITHER, BUT ARE ASSUMED TO BE UNITY. +* UNCHANGED ON EXIT. +* +* LDA - INTEGER. +* ON ENTRY, LDA SPECIFIES THE FIRST DIMENSION OF A AS DECLARED +* IN THE CALLING (SUB) PROGRAM. WHEN SIDE = 'L' OR 'L' THEN +* LDA MUST BE AT LEAST MAX( 1, M ), WHEN SIDE = 'R' OR 'R' +* THEN LDA MUST BE AT LEAST MAX( 1, N ). +* UNCHANGED ON EXIT. +* +* B - DOUBLE PRECISION ARRAY OF DIMENSION ( LDB, N ). +* BEFORE ENTRY, THE LEADING M BY N PART OF THE ARRAY B MUST +* CONTAIN THE MATRIX B, AND ON EXIT IS OVERWRITTEN BY THE +* TRANSFORMED MATRIX. +* +* LDB - INTEGER. +* ON ENTRY, LDB SPECIFIES THE FIRST DIMENSION OF B AS DECLARED +* IN THE CALLING (SUB) PROGRAM. LDB MUST BE AT LEAST +* MAX( 1, M ). +* UNCHANGED ON EXIT. +* +* +* LEVEL 3 BLAS ROUTINE. +* +* -- WRITTEN ON 8-FEBRUARY-1989. +* JACK DONGARRA, ARGONNE NATIONAL LABORATORY. +* IAIN DUFF, AERE HARWELL. +* JEREMY DU CROZ, NUMERICAL ALGORITHMS GROUP LTD. +* SVEN HAMMARLING, NUMERICAL ALGORITHMS GROUP LTD. +* +* +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. LOCAL SCALARS .. + LOGICAL LSIDE, NOUNIT, UPPER + INTEGER I, INFO, J, K, NROWA + DOUBLE PRECISION TEMP +* .. PARAMETERS .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + LSIDE = LSAME( SIDE , 'L' ) + IF( LSIDE )THEN + NROWA = M + ELSE + NROWA = N + END IF + NOUNIT = LSAME( DIAG , 'N' ) + UPPER = LSAME( UPLO , 'U' ) +* + INFO = 0 + IF( ( .NOT.LSIDE ).AND. + $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN + INFO = 2 + ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. + $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. + $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN + INFO = 3 + ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. + $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN + INFO = 4 + ELSE IF( M .LT.0 )THEN + INFO = 5 + ELSE IF( N .LT.0 )THEN + INFO = 6 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 9 + ELSE IF( LDB.LT.MAX( 1, M ) )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DTRMM ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE. +* + IF( N.EQ.0 ) + $ RETURN +* +* AND WHEN ALPHA.EQ.ZERO. +* + IF( ALPHA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, M + B( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* START THE OPERATIONS. +* + IF( LSIDE )THEN + IF( LSAME( TRANSA, 'N' ) )THEN +* +* FORM B := ALPHA*A*B. +* + IF( UPPER )THEN + DO 50, J = 1, N + DO 40, K = 1, M + IF( B( K, J ).NE.ZERO )THEN + TEMP = ALPHA*B( K, J ) + DO 30, I = 1, K - 1 + B( I, J ) = B( I, J ) + TEMP*A( I, K ) + 30 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP*A( K, K ) + B( K, J ) = TEMP + END IF + 40 CONTINUE + 50 CONTINUE + ELSE + DO 80, J = 1, N + DO 70 K = M, 1, -1 + IF( B( K, J ).NE.ZERO )THEN + TEMP = ALPHA*B( K, J ) + B( K, J ) = TEMP + IF( NOUNIT ) + $ B( K, J ) = B( K, J )*A( K, K ) + DO 60, I = K + 1, M + B( I, J ) = B( I, J ) + TEMP*A( I, K ) + 60 CONTINUE + END IF + 70 CONTINUE + 80 CONTINUE + END IF + ELSE +* +* FORM B := ALPHA*B*A'. +* + IF( UPPER )THEN + DO 110, J = 1, N + DO 100, I = M, 1, -1 + TEMP = B( I, J ) + IF( NOUNIT ) + $ TEMP = TEMP*A( I, I ) + DO 90, K = 1, I - 1 + TEMP = TEMP + A( K, I )*B( K, J ) + 90 CONTINUE + B( I, J ) = ALPHA*TEMP + 100 CONTINUE + 110 CONTINUE + ELSE + DO 140, J = 1, N + DO 130, I = 1, M + TEMP = B( I, J ) + IF( NOUNIT ) + $ TEMP = TEMP*A( I, I ) + DO 120, K = I + 1, M + TEMP = TEMP + A( K, I )*B( K, J ) + 120 CONTINUE + B( I, J ) = ALPHA*TEMP + 130 CONTINUE + 140 CONTINUE + END IF + END IF + ELSE + IF( LSAME( TRANSA, 'N' ) )THEN +* +* FORM B := ALPHA*B*A. +* + IF( UPPER )THEN + DO 180, J = N, 1, -1 + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 150, I = 1, M + B( I, J ) = TEMP*B( I, J ) + 150 CONTINUE + DO 170, K = 1, J - 1 + IF( A( K, J ).NE.ZERO )THEN + TEMP = ALPHA*A( K, J ) + DO 160, I = 1, M + B( I, J ) = B( I, J ) + TEMP*B( I, K ) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + ELSE + DO 220, J = 1, N + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*A( J, J ) + DO 190, I = 1, M + B( I, J ) = TEMP*B( I, J ) + 190 CONTINUE + DO 210, K = J + 1, N + IF( A( K, J ).NE.ZERO )THEN + TEMP = ALPHA*A( K, J ) + DO 200, I = 1, M + B( I, J ) = B( I, J ) + TEMP*B( I, K ) + 200 CONTINUE + END IF + 210 CONTINUE + 220 CONTINUE + END IF + ELSE +* +* FORM B := ALPHA*B*A'. +* + IF( UPPER )THEN + DO 260, K = 1, N + DO 240, J = 1, K - 1 + IF( A( J, K ).NE.ZERO )THEN + TEMP = ALPHA*A( J, K ) + DO 230, I = 1, M + B( I, J ) = B( I, J ) + TEMP*B( I, K ) + 230 CONTINUE + END IF + 240 CONTINUE + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*A( K, K ) + IF( TEMP.NE.ONE )THEN + DO 250, I = 1, M + B( I, K ) = TEMP*B( I, K ) + 250 CONTINUE + END IF + 260 CONTINUE + ELSE + DO 300, K = N, 1, -1 + DO 280, J = K + 1, N + IF( A( J, K ).NE.ZERO )THEN + TEMP = ALPHA*A( J, K ) + DO 270, I = 1, M + B( I, J ) = B( I, J ) + TEMP*B( I, K ) + 270 CONTINUE + END IF + 280 CONTINUE + TEMP = ALPHA + IF( NOUNIT ) + $ TEMP = TEMP*A( K, K ) + IF( TEMP.NE.ONE )THEN + DO 290, I = 1, M + B( I, K ) = TEMP*B( I, K ) + 290 CONTINUE + END IF + 300 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* END OF DTRMM . +* + END +CUT HERE............ diff --git a/lapack.f b/lapack.f new file mode 100644 index 0000000..b911039 --- /dev/null +++ b/lapack.f @@ -0,0 +1,12442 @@ +C ------------- BELOW IS DSYEVX -------------------- +CAT > DSYEVX.F <<'CUT HERE............' + SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, + $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, + $ IFAIL, INFO ) +* +* -- LAPACK DRIVER ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* MARCH 31, 1993 +* +* .. SCALAR ARGUMENTS .. + CHARACTER JOBZ, RANGE, UPLO + INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. ARRAY ARGUMENTS .. + INTEGER IFAIL( * ), IWORK( * ) + DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* PURPOSE +* ======= +* +* DSYEVX COMPUTES SELECTED EIGENVALUES AND, OPTIONALLY, EIGENVECTORS +* OF A REAL SYMMETRIC MATRIX A. EIGENVALUES AND EIGENVECTORS CAN BE +* SELECTED BY SPECIFYING EITHER A RANGE OF VALUES OR A RANGE OF INDICES +* FOR THE DESIRED EIGENVALUES. +* +* ARGUMENTS +* ========= +* +* JOBZ (INPUT) CHARACTER*1 +* = 'N': COMPUTE EIGENVALUES ONLY; +* = 'V': COMPUTE EIGENVALUES AND EIGENVECTORS. +* +* RANGE (INPUT) CHARACTER*1 +* = 'A': ALL EIGENVALUES WILL BE FOUND. +* = 'V': ALL EIGENVALUES IN THE HALF-OPEN INTERVAL (VL,VU] +* WILL BE FOUND. +* = 'I': THE IL-TH THROUGH IU-TH EIGENVALUES WILL BE FOUND. +* +* UPLO (INPUT) CHARACTER*1 +* = 'U': UPPER TRIANGLE OF A IS STORED; +* = 'L': LOWER TRIANGLE OF A IS STORED. +* +* N (INPUT) INTEGER +* THE ORDER OF THE MATRIX A. N >= 0. +* +* A (INPUT/WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LDA, N) +* ON ENTRY, THE SYMMETRIC MATRIX A. IF UPLO = 'U', THE +* LEADING N-BY-N UPPER TRIANGULAR PART OF A CONTAINS THE +* UPPER TRIANGULAR PART OF THE MATRIX A. IF UPLO = 'L', +* THE LEADING N-BY-N LOWER TRIANGULAR PART OF A CONTAINS +* THE LOWER TRIANGULAR PART OF THE MATRIX A. +* ON EXIT, THE LOWER TRIANGLE (IF UPLO='L') OR THE UPPER +* TRIANGLE (IF UPLO='U') OF A, INCLUDING THE DIAGONAL, IS +* DESTROYED. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N). +* +* VL (INPUT) DOUBLE PRECISION +* IF RANGE='V', THE LOWER BOUND OF THE INTERVAL TO BE SEARCHED +* FOR EIGENVALUES. NOT REFERENCED IF RANGE = 'A' OR 'I'. +* +* VU (INPUT) DOUBLE PRECISION +* IF RANGE='V', THE UPPER BOUND OF THE INTERVAL TO BE SEARCHED +* FOR EIGENVALUES. NOT REFERENCED IF RANGE = 'A' OR 'I'. +* +* IL (INPUT) INTEGER +* IF RANGE='I', THE INDEX (FROM SMALLEST TO LARGEST) OF THE +* SMALLEST EIGENVALUE TO BE RETURNED. IL >= 1. +* NOT REFERENCED IF RANGE = 'A' OR 'V'. +* +* IU (INPUT) INTEGER +* IF RANGE='I', THE INDEX (FROM SMALLEST TO LARGEST) OF THE +* LARGEST EIGENVALUE TO BE RETURNED. MIN(IL,N) <= IU <= N. +* NOT REFERENCED IF RANGE = 'A' OR 'V'. +* +* ABSTOL (INPUT) DOUBLE PRECISION +* THE ABSOLUTE ERROR TOLERANCE FOR THE EIGENVALUES. +* AN APPROXIMATE EIGENVALUE IS ACCEPTED AS CONVERGED +* WHEN IT IS DETERMINED TO LIE IN AN INTERVAL [A,B] +* OF WIDTH LESS THAN OR EQUAL TO +* +* ABSTOL + EPS * MAX( |A|,|B| ) , +* +* WHERE EPS IS THE MACHINE PRECISION. IF ABSTOL IS LESS THAN +* OR EQUAL TO ZERO, THEN EPS*|T| WILL BE USED IN ITS PLACE, +* WHERE |T| IS THE 1-NORM OF THE TRIDIAGONAL MATRIX OBTAINED +* BY REDUCING A TO TRIDIAGONAL FORM. +* +* SEE "COMPUTING SMALL SINGULAR VALUES OF BIDIAGONAL MATRICES +* WITH GUARANTEED HIGH RELATIVE ACCURACY," BY DEMMEL AND +* KAHAN, LAPACK WORKING NOTE #3. +* +* M (OUTPUT) INTEGER +* THE TOTAL NUMBER OF EIGENVALUES FOUND. 0 <= M <= N. +* IF RANGE = 'A', M = N, AND IF RANGE = 'I', M = IU-IL+1. +* +* W (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* ON NORMAL EXIT, THE FIRST M ENTRIES CONTAIN THE SELECTED +* EIGENVALUES IN ASCENDING ORDER. +* +* Z (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDZ, MAX(1,M)) +* IF JOBZ = 'V', THEN IF INFO = 0, THE FIRST M COLUMNS OF Z +* CONTAIN THE ORTHONORMAL EIGENVECTORS OF THE MATRIX +* CORRESPONDING TO THE SELECTED EIGENVALUES. IF AN EIGENVECTOR +* FAILS TO CONVERGE, THEN THAT COLUMN OF Z CONTAINS THE LATEST +* APPROXIMATION TO THE EIGENVECTOR, AND THE INDEX OF THE +* EIGENVECTOR IS RETURNED IN IFAIL. +* IF JOBZ = 'N', THEN Z IS NOT REFERENCED. +* NOTE: THE USER MUST ENSURE THAT AT LEAST MAX(1,M) COLUMNS ARE +* SUPPLIED IN THE ARRAY Z; IF RANGE = 'V', THE EXACT VALUE OF M +* IS NOT KNOWN IN ADVANCE AND AN UPPER BOUND MUST BE USED. +* +* LDZ (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY Z. LDZ >= 1, AND IF +* JOBZ = 'V', LDZ >= MAX(1,N). +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK) +* ON EXIT, IF INFO = 0, WORK(1) RETURNS THE OPTIMAL LWORK. +* +* LWORK (INPUT) INTEGER +* THE LENGTH OF THE ARRAY WORK. LWORK >= MAX(1,8*N). +* FOR OPTIMAL EFFICIENCY, LWORK >= (NB+3)*N, +* WHERE NB IS THE BLOCKSIZE FOR DSYTRD RETURNED BY ILAENV. +* +* IWORK (WORKSPACE) INTEGER ARRAY, DIMENSION (5*N) +* +* IFAIL (OUTPUT) INTEGER ARRAY, DIMENSION (N) +* IF JOBZ = 'V', THEN IF INFO = 0, THE FIRST M ELEMENTS OF +* IFAIL ARE ZERO. IF INFO > 0, THEN IFAIL CONTAINS THE +* INDICES OF THE EIGENVECTORS THAT FAILED TO CONVERGE. +* IF JOBZ = 'N', THEN IFAIL IS NOT REFERENCED. +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE +* > 0: IF INFO = I, THEN I EIGENVECTORS FAILED TO CONVERGE. +* THEIR INDICES ARE STORED IN ARRAY IFAIL. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. LOCAL SCALARS .. + LOGICAL ALLEIG, INDEIG, LOWER, VALEIG, WANTZ + CHARACTER ORDER + INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + $ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE, + $ ITMP1, J, JJ, LLWORK, LLWRKN, LOPT, NSPLIT + DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, + $ SIGMA, SMLNUM, TMP1, VLL, VUU +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLANSY + EXTERNAL LSAME, DLAMCH, DLANSY +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ, + $ DSTEIN, DSTEQR, DSTERF, DSWAP, DSYTRD, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN, SQRT +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + LOWER = LSAME( UPLO, 'L' ) + WANTZ = LSAME( JOBZ, 'V' ) + ALLEIG = LSAME( RANGE, 'A' ) + VALEIG = LSAME( RANGE, 'V' ) + INDEIG = LSAME( RANGE, 'I' ) +* + INFO = 0 + IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN + INFO = -1 + ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN + INFO = -2 + ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -6 + ELSE IF( VALEIG .AND. N.GT.0 .AND. VU.LE.VL ) THEN + INFO = -8 + ELSE IF( INDEIG .AND. IL.LT.1 ) THEN + INFO = -9 + ELSE IF( INDEIG .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN + INFO = -10 + ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN + INFO = -15 + ELSE IF( LWORK.LT.MAX( 1, 8*N ) ) THEN + INFO = -17 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYEVX', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + M = 0 + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( N.EQ.1 ) THEN + WORK( 1 ) = 7 + IF( ALLEIG .OR. INDEIG ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + ELSE + IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN + M = 1 + W( 1 ) = A( 1, 1 ) + END IF + END IF + IF( WANTZ ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* +* GET MACHINE CONSTANTS. +* + SAFMIN = DLAMCH( 'SAFE MINIMUM' ) + EPS = DLAMCH( 'PRECISION' ) + SMLNUM = SAFMIN / EPS + BIGNUM = ONE / SMLNUM + RMIN = SQRT( SMLNUM ) + RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) ) +* +* SCALE MATRIX TO ALLOWABLE RANGE, IF NECESSARY. +* + ISCALE = 0 + ABSTLL = ABSTOL + IF( VALEIG ) THEN + VLL = VL + VUU = VU + END IF + ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK ) + IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN + ISCALE = 1 + SIGMA = RMIN / ANRM + ELSE IF( ANRM.GT.RMAX ) THEN + ISCALE = 1 + SIGMA = RMAX / ANRM + END IF + IF( ISCALE.EQ.1 ) THEN + IF( LOWER ) THEN + DO 10 J = 1, N + CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 ) + 10 CONTINUE + ELSE + DO 20 J = 1, N + CALL DSCAL( J, SIGMA, A( 1, J ), 1 ) + 20 CONTINUE + END IF + IF( ABSTOL.GT.0 ) + $ ABSTLL = ABSTOL*SIGMA + IF( VALEIG ) THEN + VLL = VL*SIGMA + VUU = VU*SIGMA + END IF + END IF +* +* CALL DSYTRD TO REDUCE SYMMETRIC MATRIX TO TRIDIAGONAL FORM. +* + INDTAU = 1 + INDE = INDTAU + N + INDD = INDE + N + INDWRK = INDD + N + LLWORK = LWORK - INDWRK + 1 + CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ), + $ WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO ) + LOPT = 3*N + WORK( INDWRK ) +* +* IF ALL EIGENVALUES ARE DESIRED AND ABSTOL IS LESS THAN OR EQUAL TO +* ZERO, THEN CALL DSTERF OR DORGTR AND SSTEQR. IF THIS FAILS FOR +* SOME EIGENVALUE, THEN TRY DSTEBZ. +* + IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. + $ ( ABSTOL.LE.ZERO ) ) THEN + CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) + INDEE = INDWRK + 2*N + IF( .NOT.WANTZ ) THEN + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTERF( N, W, WORK( INDEE ), INFO ) + ELSE + CALL DLACPY( 'A', N, N, A, LDA, Z, LDZ ) + CALL DORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ), + $ WORK( INDWRK ), LLWORK, IINFO ) + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ, + $ WORK( INDWRK ), INFO ) + IF( INFO.EQ.0 ) THEN + DO 30 I = 1, N + IFAIL( I ) = 0 + 30 CONTINUE + END IF + END IF + IF( INFO.EQ.0 ) THEN + M = N + GO TO 40 + END IF + INFO = 0 + END IF +* +* OTHERWISE, CALL DSTEBZ AND, IF EIGENVECTORS ARE DESIRED, SSTEIN. +* + IF( WANTZ ) THEN + ORDER = 'B' + ELSE + ORDER = 'E' + END IF + INDIBL = 1 + INDISP = INDIBL + N + INDIWO = INDISP + N + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL, + $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W, + $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ), + $ IWORK( INDIWO ), INFO ) +* + IF( WANTZ ) THEN + CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W, + $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ, + $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO ) +* +* APPLY ORTHOGONAL MATRIX USED IN REDUCTION TO TRIDIAGONAL +* FORM TO EIGENVECTORS RETURNED BY DSTEIN. +* + INDWKN = INDE + LLWRKN = LWORK - INDWKN + 1 + CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) + END IF +* +* IF MATRIX WAS SCALED, THEN RESCALE EIGENVALUES APPROPRIATELY. +* + 40 CONTINUE + IF( ISCALE.EQ.1 ) THEN + IF( INFO.EQ.0 ) THEN + IMAX = M + ELSE + IMAX = INFO - 1 + END IF + CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) + END IF +* +* IF EIGENVALUES ARE NOT IN ORDER, THEN SORT THEM, ALONG WITH +* EIGENVECTORS. +* + IF( WANTZ ) THEN + DO 60 J = 1, M - 1 + I = 0 + TMP1 = W( J ) + DO 50 JJ = J + 1, M + IF( W( JJ ).LT.TMP1 ) THEN + I = JJ + TMP1 = W( JJ ) + END IF + 50 CONTINUE +* + IF( I.NE.0 ) THEN + ITMP1 = IWORK( INDIBL+I-1 ) + W( I ) = W( J ) + IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 ) + W( J ) = TMP1 + IWORK( INDIBL+J-1 ) = ITMP1 + CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 ) + IF( INFO.NE.0 ) THEN + ITMP1 = IFAIL( I ) + IFAIL( I ) = IFAIL( J ) + IFAIL( J ) = ITMP1 + END IF + END IF + 60 CONTINUE + END IF +* +* SET WORK(1) TO OPTIMAL WORKSPACE SIZE. +* + WORK( 1 ) = MAX( 7*N, LOPT ) +* + RETURN +* +* END OF DSYEVX +* + END +CUT HERE............ +CAT > DORMTR.F <<'CUT HERE............' + SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* MARCH 31, 1993 +* +* .. SCALAR ARGUMENTS .. + CHARACTER SIDE, TRANS, UPLO + INTEGER INFO, LDA, LDC, LWORK, M, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), + $ WORK( LWORK ) +* .. +* +* PURPOSE +* ======= +* +* DORMTR OVERWRITES THE GENERAL REAL M-BY-N MATRIX C WITH +* +* SIDE = 'L' SIDE = 'R' +* TRANS = 'N': Q * C C * Q +* TRANS = 'T': Q**T * C C * Q**T +* +* WHERE Q IS A REAL ORTHOGONAL MATRIX OF ORDER NQ, WITH NQ = M IF +* SIDE = 'L' AND NQ = N IF SIDE = 'R'. Q IS DEFINED AS THE PRODUCT OF +* NQ-1 ELEMENTARY REFLECTORS, AS RETURNED BY DSYTRD: +* +* IF UPLO = 'U', Q = H(NQ-1) . . . H(2) H(1); +* +* IF UPLO = 'L', Q = H(1) H(2) . . . H(NQ-1). +* +* ARGUMENTS +* ========= +* +* SIDE (INPUT) CHARACTER*1 +* = 'L': APPLY Q OR Q**T FROM THE LEFT; +* = 'R': APPLY Q OR Q**T FROM THE RIGHT. +* +* UPLO (INPUT) CHARACTER*1 +* = 'U': UPPER TRIANGLE OF A CONTAINS ELEMENTARY REFLECTORS +* FROM DSYTRD; +* = 'L': LOWER TRIANGLE OF A CONTAINS ELEMENTARY REFLECTORS +* FROM DSYTRD. +* +* TRANS (INPUT) CHARACTER*1 +* = 'N': NO TRANSPOSE, APPLY Q; +* = 'T': TRANSPOSE, APPLY Q**T. +* +* M (INPUT) INTEGER +* THE NUMBER OF ROWS OF THE MATRIX C. M >= 0. +* +* N (INPUT) INTEGER +* THE NUMBER OF COLUMNS OF THE MATRIX C. N >= 0. +* +* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION +* (LDA,M) IF SIDE = 'L' +* (LDA,N) IF SIDE = 'R' +* THE VECTORS WHICH DEFINE THE ELEMENTARY REFLECTORS, AS +* RETURNED BY DSYTRD. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. +* LDA >= MAX(1,M) IF SIDE = 'L'; LDA >= MAX(1,N) IF SIDE = 'R'. +* +* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION +* (M-1) IF SIDE = 'L' +* (N-1) IF SIDE = 'R' +* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY +* REFLECTOR H(I), AS RETURNED BY DSYTRD. +* +* C (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDC,N) +* ON ENTRY, THE M-BY-N MATRIX C. +* ON EXIT, C IS OVERWRITTEN BY Q*C OR Q**T*C OR C*Q**T OR C*Q. +* +* LDC (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY C. LDC >= MAX(1,M). +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK) +* ON EXIT, IF INFO = 0, WORK(1) RETURNS THE OPTIMAL LWORK. +* +* LWORK (INPUT) INTEGER +* THE DIMENSION OF THE ARRAY WORK. +* IF SIDE = 'L', LWORK >= MAX(1,N); +* IF SIDE = 'R', LWORK >= MAX(1,M). +* FOR OPTIMUM PERFORMANCE LWORK >= N*NB IF SIDE = 'L', AND +* LWORK >= M*NB IF SIDE = 'R', WHERE NB IS THE OPTIMAL +* BLOCKSIZE. +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE +* +* ===================================================================== +* +* .. LOCAL SCALARS .. + LOGICAL LEFT, UPPER + INTEGER I1, I2, IINFO, MI, NI, NQ, NW +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DORMQL, DORMQR, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + UPPER = LSAME( UPLO, 'U' ) +* +* NQ IS THE ORDER OF Q AND NW IS THE MINIMUM DIMENSION OF WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -2 + ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) + $ THEN + INFO = -3 + ELSE IF( M.LT.0 ) THEN + INFO = -4 + ELSE IF( N.LT.0 ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN + INFO = -12 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMTR', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( LEFT ) THEN + MI = M - 1 + NI = N + ELSE + MI = M + NI = N - 1 + END IF +* + IF( UPPER ) THEN +* +* Q WAS DETERMINED BY A CALL TO DSYTRD WITH UPLO = 'U' +* + CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C, + $ LDC, WORK, LWORK, IINFO ) + ELSE +* +* Q WAS DETERMINED BY A CALL TO DSYTRD WITH UPLO = 'L' +* + IF( LEFT ) THEN + I1 = 2 + I2 = 1 + ELSE + I1 = 1 + I2 = 2 + END IF + CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, + $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) + END IF + RETURN +* +* END OF DORMTR +* + END +CUT HERE............ +CAT > DORMQR.F <<'CUT HERE............' + SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* MARCH 31, 1993 +* +* .. SCALAR ARGUMENTS .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), + $ WORK( LWORK ) +* .. +* +* PURPOSE +* ======= +* +* DORMQR OVERWRITES THE GENERAL REAL M-BY-N MATRIX C WITH +* +* SIDE = 'L' SIDE = 'R' +* TRANS = 'N': Q * C C * Q +* TRANS = 'T': Q**T * C C * Q**T +* +* WHERE Q IS A REAL ORTHOGONAL MATRIX DEFINED AS THE PRODUCT OF K +* ELEMENTARY REFLECTORS +* +* Q = H(1) H(2) . . . H(K) +* +* AS RETURNED BY DGEQRF. Q IS OF ORDER M IF SIDE = 'L' AND OF ORDER N +* IF SIDE = 'R'. +* +* ARGUMENTS +* ========= +* +* SIDE (INPUT) CHARACTER*1 +* = 'L': APPLY Q OR Q**T FROM THE LEFT; +* = 'R': APPLY Q OR Q**T FROM THE RIGHT. +* +* TRANS (INPUT) CHARACTER*1 +* = 'N': NO TRANSPOSE, APPLY Q; +* = 'T': TRANSPOSE, APPLY Q**T. +* +* M (INPUT) INTEGER +* THE NUMBER OF ROWS OF THE MATRIX C. M >= 0. +* +* N (INPUT) INTEGER +* THE NUMBER OF COLUMNS OF THE MATRIX C. N >= 0. +* +* K (INPUT) INTEGER +* THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES +* THE MATRIX Q. +* IF SIDE = 'L', M >= K >= 0; +* IF SIDE = 'R', N >= K >= 0. +* +* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,K) +* THE I-TH COLUMN MUST CONTAIN THE VECTOR WHICH DEFINES THE +* ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS RETURNED BY +* DGEQRF IN THE FIRST K COLUMNS OF ITS ARRAY ARGUMENT A. +* A IS MODIFIED BY THE ROUTINE BUT RESTORED ON EXIT. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. +* IF SIDE = 'L', LDA >= MAX(1,M); +* IF SIDE = 'R', LDA >= MAX(1,N). +* +* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K) +* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY +* REFLECTOR H(I), AS RETURNED BY DGEQRF. +* +* C (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDC,N) +* ON ENTRY, THE M-BY-N MATRIX C. +* ON EXIT, C IS OVERWRITTEN BY Q*C OR Q**T*C OR C*Q**T OR C*Q. +* +* LDC (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY C. LDC >= MAX(1,M). +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK) +* ON EXIT, IF INFO = 0, WORK(1) RETURNS THE OPTIMAL LWORK. +* +* LWORK (INPUT) INTEGER +* THE DIMENSION OF THE ARRAY WORK. +* IF SIDE = 'L', LWORK >= MAX(1,N); +* IF SIDE = 'R', LWORK >= MAX(1,M). +* FOR OPTIMUM PERFORMANCE LWORK >= N*NB IF SIDE = 'L', AND +* LWORK >= M*NB IF SIDE = 'R', WHERE NB IS THE OPTIMAL +* BLOCKSIZE. +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE +* +* ===================================================================== +* +* .. PARAMETERS .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. LOCAL SCALARS .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, + $ MI, NB, NBMIN, NI, NQ, NW +* .. +* .. LOCAL ARRAYS .. + DOUBLE PRECISION T( LDT, NBMAX ) +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ IS THE ORDER OF Q AND NW IS THE MINIMUM DIMENSION OF WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN + INFO = -12 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMQR', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* DETERMINE THE BLOCK SIZE. NB MAY BE AT MOST NBMAX, WHERE NBMAX +* IS USED TO DEFINE THE LOCAL ARRAY T. +* + NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* USE UNBLOCKED CODE +* + CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, + $ IINFO ) + ELSE +* +* USE BLOCKED CODE +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* FORM THE TRIANGULAR FACTOR OF THE BLOCK REFLECTOR +* H = H(I) H(I+1) . . . H(I+IB-1) +* + CALL DLARFT( 'FORWARD', 'COLUMNWISE', NQ-I+1, IB, A( I, I ), + $ LDA, TAU( I ), T, LDT ) + IF( LEFT ) THEN +* +* H OR H' IS APPLIED TO C(I:M,1:N) +* + MI = M - I + 1 + IC = I + ELSE +* +* H OR H' IS APPLIED TO C(1:M,I:N) +* + NI = N - I + 1 + JC = I + END IF +* +* APPLY H OR H' +* + CALL DLARFB( SIDE, TRANS, 'FORWARD', 'COLUMNWISE', MI, NI, + $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, + $ WORK, LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = IWS + RETURN +* +* END OF DORMQR +* + END +CUT HERE............ +CAT > DORM2R.F <<'CUT HERE............' + SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* FEBRUARY 29, 1992 +* +* .. SCALAR ARGUMENTS .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* PURPOSE +* ======= +* +* DORM2R OVERWRITES THE GENERAL REAL M BY N MATRIX C WITH +* +* Q * C IF SIDE = 'L' AND TRANS = 'N', OR +* +* Q'* C IF SIDE = 'L' AND TRANS = 'T', OR +* +* C * Q IF SIDE = 'R' AND TRANS = 'N', OR +* +* C * Q' IF SIDE = 'R' AND TRANS = 'T', +* +* WHERE Q IS A REAL ORTHOGONAL MATRIX DEFINED AS THE PRODUCT OF K +* ELEMENTARY REFLECTORS +* +* Q = H(1) H(2) . . . H(K) +* +* AS RETURNED BY DGEQRF. Q IS OF ORDER M IF SIDE = 'L' AND OF ORDER N +* IF SIDE = 'R'. +* +* ARGUMENTS +* ========= +* +* SIDE (INPUT) CHARACTER*1 +* = 'L': APPLY Q OR Q' FROM THE LEFT +* = 'R': APPLY Q OR Q' FROM THE RIGHT +* +* TRANS (INPUT) CHARACTER*1 +* = 'N': APPLY Q (NO TRANSPOSE) +* = 'T': APPLY Q' (TRANSPOSE) +* +* M (INPUT) INTEGER +* THE NUMBER OF ROWS OF THE MATRIX C. M >= 0. +* +* N (INPUT) INTEGER +* THE NUMBER OF COLUMNS OF THE MATRIX C. N >= 0. +* +* K (INPUT) INTEGER +* THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES +* THE MATRIX Q. +* IF SIDE = 'L', M >= K >= 0; +* IF SIDE = 'R', N >= K >= 0. +* +* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,K) +* THE I-TH COLUMN MUST CONTAIN THE VECTOR WHICH DEFINES THE +* ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS RETURNED BY +* DGEQRF IN THE FIRST K COLUMNS OF ITS ARRAY ARGUMENT A. +* A IS MODIFIED BY THE ROUTINE BUT RESTORED ON EXIT. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. +* IF SIDE = 'L', LDA >= MAX(1,M); +* IF SIDE = 'R', LDA >= MAX(1,N). +* +* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K) +* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY +* REFLECTOR H(I), AS RETURNED BY DGEQRF. +* +* C (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDC,N) +* ON ENTRY, THE M BY N MATRIX C. +* ON EXIT, C IS OVERWRITTEN BY Q*C OR Q'*C OR C*Q' OR C*Q. +* +* LDC (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY C. LDC >= MAX(1,M). +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION +* (N) IF SIDE = 'L', +* (M) IF SIDE = 'R' +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. LOCAL SCALARS .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ + DOUBLE PRECISION AII +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLARF, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ IS THE ORDER OF Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORM2R', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) + $ THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + JC = 1 + ELSE + MI = M + IC = 1 + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(I) IS APPLIED TO C(I:M,1:N) +* + MI = M - I + 1 + IC = I + ELSE +* +* H(I) IS APPLIED TO C(1:M,I:N) +* + NI = N - I + 1 + JC = I + END IF +* +* APPLY H(I) +* + AII = A( I, I ) + A( I, I ) = ONE + CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), + $ LDC, WORK ) + A( I, I ) = AII + 10 CONTINUE + RETURN +* +* END OF DORM2R +* + END +CUT HERE............ +CAT > DORMQL.F <<'CUT HERE............' + SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, LWORK, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* MARCH 31, 1993 +* +* .. SCALAR ARGUMENTS .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, LWORK, M, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), + $ WORK( LWORK ) +* .. +* +* PURPOSE +* ======= +* +* DORMQL OVERWRITES THE GENERAL REAL M-BY-N MATRIX C WITH +* +* SIDE = 'L' SIDE = 'R' +* TRANS = 'N': Q * C C * Q +* TRANS = 'T': Q**T * C C * Q**T +* +* WHERE Q IS A REAL ORTHOGONAL MATRIX DEFINED AS THE PRODUCT OF K +* ELEMENTARY REFLECTORS +* +* Q = H(K) . . . H(2) H(1) +* +* AS RETURNED BY DGEQLF. Q IS OF ORDER M IF SIDE = 'L' AND OF ORDER N +* IF SIDE = 'R'. +* +* ARGUMENTS +* ========= +* +* SIDE (INPUT) CHARACTER*1 +* = 'L': APPLY Q OR Q**T FROM THE LEFT; +* = 'R': APPLY Q OR Q**T FROM THE RIGHT. +* +* TRANS (INPUT) CHARACTER*1 +* = 'N': NO TRANSPOSE, APPLY Q; +* = 'T': TRANSPOSE, APPLY Q**T. +* +* M (INPUT) INTEGER +* THE NUMBER OF ROWS OF THE MATRIX C. M >= 0. +* +* N (INPUT) INTEGER +* THE NUMBER OF COLUMNS OF THE MATRIX C. N >= 0. +* +* K (INPUT) INTEGER +* THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES +* THE MATRIX Q. +* IF SIDE = 'L', M >= K >= 0; +* IF SIDE = 'R', N >= K >= 0. +* +* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,K) +* THE I-TH COLUMN MUST CONTAIN THE VECTOR WHICH DEFINES THE +* ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS RETURNED BY +* DGEQLF IN THE LAST K COLUMNS OF ITS ARRAY ARGUMENT A. +* A IS MODIFIED BY THE ROUTINE BUT RESTORED ON EXIT. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. +* IF SIDE = 'L', LDA >= MAX(1,M); +* IF SIDE = 'R', LDA >= MAX(1,N). +* +* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K) +* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY +* REFLECTOR H(I), AS RETURNED BY DGEQLF. +* +* C (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDC,N) +* ON ENTRY, THE M-BY-N MATRIX C. +* ON EXIT, C IS OVERWRITTEN BY Q*C OR Q**T*C OR C*Q**T OR C*Q. +* +* LDC (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY C. LDC >= MAX(1,M). +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK) +* ON EXIT, IF INFO = 0, WORK(1) RETURNS THE OPTIMAL LWORK. +* +* LWORK (INPUT) INTEGER +* THE DIMENSION OF THE ARRAY WORK. +* IF SIDE = 'L', LWORK >= MAX(1,N); +* IF SIDE = 'R', LWORK >= MAX(1,M). +* FOR OPTIMUM PERFORMANCE LWORK >= N*NB IF SIDE = 'L', AND +* LWORK >= M*NB IF SIDE = 'R', WHERE NB IS THE OPTIMAL +* BLOCKSIZE. +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE +* +* ===================================================================== +* +* .. PARAMETERS .. + INTEGER NBMAX, LDT + PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) +* .. +* .. LOCAL SCALARS .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, IB, IINFO, IWS, LDWORK, MI, NB, + $ NBMIN, NI, NQ, NW +* .. +* .. LOCAL ARRAYS .. + DOUBLE PRECISION T( LDT, NBMAX ) +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLARFB, DLARFT, DORM2L, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ IS THE ORDER OF Q AND NW IS THE MINIMUM DIMENSION OF WORK +* + IF( LEFT ) THEN + NQ = M + NW = N + ELSE + NQ = N + NW = M + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN + INFO = -12 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORMQL', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* DETERMINE THE BLOCK SIZE. NB MAY BE AT MOST NBMAX, WHERE NBMAX +* IS USED TO DEFINE THE LOCAL ARRAY T. +* + NB = MIN( NBMAX, ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N, K, + $ -1 ) ) + NBMIN = 2 + LDWORK = NW + IF( NB.GT.1 .AND. NB.LT.K ) THEN + IWS = NW*NB + IF( LWORK.LT.IWS ) THEN + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORMQL', SIDE // TRANS, M, N, K, + $ -1 ) ) + END IF + ELSE + IWS = NW + END IF +* + IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN +* +* USE UNBLOCKED CODE +* + CALL DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, + $ IINFO ) + ELSE +* +* USE BLOCKED CODE +* + IF( ( LEFT .AND. NOTRAN ) .OR. + $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN + I1 = 1 + I2 = K + I3 = NB + ELSE + I1 = ( ( K-1 ) / NB )*NB + 1 + I2 = 1 + I3 = -NB + END IF +* + IF( LEFT ) THEN + NI = N + ELSE + MI = M + END IF +* + DO 10 I = I1, I2, I3 + IB = MIN( NB, K-I+1 ) +* +* FORM THE TRIANGULAR FACTOR OF THE BLOCK REFLECTOR +* H = H(I+IB-1) . . . H(I+1) H(I) +* + CALL DLARFT( 'BACKWARD', 'COLUMNWISE', NQ-K+I+IB-1, IB, + $ A( 1, I ), LDA, TAU( I ), T, LDT ) + IF( LEFT ) THEN +* +* H OR H' IS APPLIED TO C(1:M-K+I+IB-1,1:N) +* + MI = M - K + I + IB - 1 + ELSE +* +* H OR H' IS APPLIED TO C(1:M,1:N-K+I+IB-1) +* + NI = N - K + I + IB - 1 + END IF +* +* APPLY H OR H' +* + CALL DLARFB( SIDE, TRANS, 'BACKWARD', 'COLUMNWISE', MI, NI, + $ IB, A( 1, I ), LDA, T, LDT, C, LDC, WORK, + $ LDWORK ) + 10 CONTINUE + END IF + WORK( 1 ) = IWS + RETURN +* +* END OF DORMQL +* + END +CUT HERE............ +CAT > DORM2L.F <<'CUT HERE............' + SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, + $ WORK, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* FEBRUARY 29, 1992 +* +* .. SCALAR ARGUMENTS .. + CHARACTER SIDE, TRANS + INTEGER INFO, K, LDA, LDC, M, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) +* .. +* +* PURPOSE +* ======= +* +* DORM2L OVERWRITES THE GENERAL REAL M BY N MATRIX C WITH +* +* Q * C IF SIDE = 'L' AND TRANS = 'N', OR +* +* Q'* C IF SIDE = 'L' AND TRANS = 'T', OR +* +* C * Q IF SIDE = 'R' AND TRANS = 'N', OR +* +* C * Q' IF SIDE = 'R' AND TRANS = 'T', +* +* WHERE Q IS A REAL ORTHOGONAL MATRIX DEFINED AS THE PRODUCT OF K +* ELEMENTARY REFLECTORS +* +* Q = H(K) . . . H(2) H(1) +* +* AS RETURNED BY DGEQLF. Q IS OF ORDER M IF SIDE = 'L' AND OF ORDER N +* IF SIDE = 'R'. +* +* ARGUMENTS +* ========= +* +* SIDE (INPUT) CHARACTER*1 +* = 'L': APPLY Q OR Q' FROM THE LEFT +* = 'R': APPLY Q OR Q' FROM THE RIGHT +* +* TRANS (INPUT) CHARACTER*1 +* = 'N': APPLY Q (NO TRANSPOSE) +* = 'T': APPLY Q' (TRANSPOSE) +* +* M (INPUT) INTEGER +* THE NUMBER OF ROWS OF THE MATRIX C. M >= 0. +* +* N (INPUT) INTEGER +* THE NUMBER OF COLUMNS OF THE MATRIX C. N >= 0. +* +* K (INPUT) INTEGER +* THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES +* THE MATRIX Q. +* IF SIDE = 'L', M >= K >= 0; +* IF SIDE = 'R', N >= K >= 0. +* +* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,K) +* THE I-TH COLUMN MUST CONTAIN THE VECTOR WHICH DEFINES THE +* ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS RETURNED BY +* DGEQLF IN THE LAST K COLUMNS OF ITS ARRAY ARGUMENT A. +* A IS MODIFIED BY THE ROUTINE BUT RESTORED ON EXIT. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. +* IF SIDE = 'L', LDA >= MAX(1,M); +* IF SIDE = 'R', LDA >= MAX(1,N). +* +* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K) +* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY +* REFLECTOR H(I), AS RETURNED BY DGEQLF. +* +* C (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDC,N) +* ON ENTRY, THE M BY N MATRIX C. +* ON EXIT, C IS OVERWRITTEN BY Q*C OR Q'*C OR C*Q' OR C*Q. +* +* LDC (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY C. LDC >= MAX(1,M). +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION +* (N) IF SIDE = 'L', +* (M) IF SIDE = 'R' +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. LOCAL SCALARS .. + LOGICAL LEFT, NOTRAN + INTEGER I, I1, I2, I3, MI, NI, NQ + DOUBLE PRECISION AII +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLARF, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 + LEFT = LSAME( SIDE, 'L' ) + NOTRAN = LSAME( TRANS, 'N' ) +* +* NQ IS THE ORDER OF Q +* + IF( LEFT ) THEN + NQ = M + ELSE + NQ = N + END IF + IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN + INFO = -1 + ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN + INFO = -2 + ELSE IF( M.LT.0 ) THEN + INFO = -3 + ELSE IF( N.LT.0 ) THEN + INFO = -4 + ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN + INFO = -5 + ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN + INFO = -7 + ELSE IF( LDC.LT.MAX( 1, M ) ) THEN + INFO = -10 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORM2L', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) + $ RETURN +* + IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) + $ THEN + I1 = 1 + I2 = K + I3 = 1 + ELSE + I1 = K + I2 = 1 + I3 = -1 + END IF +* + IF( LEFT ) THEN + NI = N + ELSE + MI = M + END IF +* + DO 10 I = I1, I2, I3 + IF( LEFT ) THEN +* +* H(I) IS APPLIED TO C(1:M-K+I,1:N) +* + MI = M - K + I + ELSE +* +* H(I) IS APPLIED TO C(1:M,1:N-K+I) +* + NI = N - K + I + END IF +* +* APPLY H(I) +* + AII = A( NQ-K+I, I ) + A( NQ-K+I, I ) = ONE + CALL DLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC, + $ WORK ) + A( NQ-K+I, I ) = AII + 10 CONTINUE + RETURN +* +* END OF DORM2L +* + END +CUT HERE............ +CAT > DSTEIN.F <<'CUT HERE............' + SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, + $ IWORK, IFAIL, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* MARCH 31, 1993 +* +* .. SCALAR ARGUMENTS .. + INTEGER INFO, LDZ, M, N +* .. +* .. ARRAY ARGUMENTS .. + INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ), + $ IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* PURPOSE +* ======= +* +* DSTEIN COMPUTES THE EIGENVECTORS OF A REAL SYMMETRIC TRIDIAGONAL +* MATRIX T CORRESPONDING TO SPECIFIED EIGENVALUES, USING INVERSE +* ITERATION. +* +* THE MAXIMUM NUMBER OF ITERATIONS ALLOWED FOR EACH EIGENVECTOR IS +* SPECIFIED BY AN INTERNAL PARAMETER MAXITS (CURRENTLY SET TO 5). +* +* ARGUMENTS +* ========= +* +* N (INPUT) INTEGER +* THE ORDER OF THE MATRIX. N >= 0. +* +* D (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* THE N DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T. +* +* E (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* THE (N-1) SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX +* T, IN ELEMENTS 1 TO N-1. E(N) NEED NOT BE SET. +* +* M (INPUT) INTEGER +* THE NUMBER OF EIGENVECTORS TO BE FOUND. 0 <= M <= N. +* +* W (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* THE FIRST M ELEMENTS OF W CONTAIN THE EIGENVALUES FOR +* WHICH EIGENVECTORS ARE TO BE COMPUTED. THE EIGENVALUES +* SHOULD BE GROUPED BY SPLIT-OFF BLOCK AND ORDERED FROM +* SMALLEST TO LARGEST WITHIN THE BLOCK. ( THE OUTPUT ARRAY +* W FROM DSTEBZ WITH ORDER = 'B' IS EXPECTED HERE. ) +* +* IBLOCK (INPUT) INTEGER ARRAY, DIMENSION (N) +* THE SUBMATRIX INDICES ASSOCIATED WITH THE CORRESPONDING +* EIGENVALUES IN W; IBLOCK(I)=1 IF EIGENVALUE W(I) BELONGS TO +* THE FIRST SUBMATRIX FROM THE TOP, =2 IF W(I) BELONGS TO +* THE SECOND SUBMATRIX, ETC. ( THE OUTPUT ARRAY IBLOCK +* FROM DSTEBZ IS EXPECTED HERE. ) +* +* ISPLIT (INPUT) INTEGER ARRAY, DIMENSION (N) +* THE SPLITTING POINTS, AT WHICH T BREAKS UP INTO SUBMATRICES. +* THE FIRST SUBMATRIX CONSISTS OF ROWS/COLUMNS 1 TO +* ISPLIT( 1 ), THE SECOND OF ROWS/COLUMNS ISPLIT( 1 )+1 +* THROUGH ISPLIT( 2 ), ETC. +* ( THE OUTPUT ARRAY ISPLIT FROM DSTEBZ IS EXPECTED HERE. ) +* +* Z (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDZ, M) +* THE COMPUTED EIGENVECTORS. THE EIGENVECTOR ASSOCIATED +* WITH THE EIGENVALUE W(I) IS STORED IN THE I-TH COLUMN OF +* Z. ANY VECTOR WHICH FAILS TO CONVERGE IS SET TO ITS CURRENT +* ITERATE AFTER MAXITS ITERATIONS. +* +* LDZ (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY Z. LDZ >= MAX(1,N). +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (5*N) +* +* IWORK (WORKSPACE) INTEGER ARRAY, DIMENSION (N) +* +* IFAIL (OUTPUT) INTEGER ARRAY, DIMENSION (M) +* ON NORMAL EXIT, ALL ELEMENTS OF IFAIL ARE ZERO. +* IF ONE OR MORE EIGENVECTORS FAIL TO CONVERGE AFTER +* MAXITS ITERATIONS, THEN THEIR INDICES ARE STORED IN +* ARRAY IFAIL. +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT. +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE +* > 0: IF INFO = I, THEN I EIGENVECTORS FAILED TO CONVERGE +* IN MAXITS ITERATIONS. THEIR INDICES ARE STORED IN +* ARRAY IFAIL. +* +* INTERNAL PARAMETERS +* =================== +* +* MAXITS INTEGER, DEFAULT = 5 +* THE MAXIMUM NUMBER OF ITERATIONS PERFORMED. +* +* EXTRA INTEGER, DEFAULT = 2 +* THE NUMBER OF ITERATIONS PERFORMED AFTER NORM GROWTH +* CRITERION IS SATISFIED, SHOULD BE AT LEAST 1. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1 + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 1.0D1, + $ ODM3 = 1.0D-3, ODM1 = 1.0D-1 ) + INTEGER MAXITS, EXTRA + PARAMETER ( MAXITS = 5, EXTRA = 2 ) +* .. +* .. LOCAL SCALARS .. + INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1, + $ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1, + $ JBLK, JMAX, NBLK, NRMCHK + DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL, + $ SCL, SEP, TOL, XJ, XJM, ZTR +* .. +* .. LOCAL ARRAYS .. + INTEGER ISEED( 4 ) +* .. +* .. EXTERNAL FUNCTIONS .. + INTEGER IDAMAX + DOUBLE PRECISION DASUM, DDOT, DLAMCH, DNRM2 + EXTERNAL IDAMAX, DASUM, DDOT, DLAMCH, DNRM2 +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DAXPY, DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, + $ XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + DO 10 I = 1, M + IFAIL( I ) = 0 + 10 CONTINUE +* + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( M.LT.0 .OR. M.GT.N ) THEN + INFO = -4 + ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN + INFO = -9 + ELSE + DO 20 J = 2, M + IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN + INFO = -6 + GO TO 30 + END IF + IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) ) + $ THEN + INFO = -5 + GO TO 30 + END IF + 20 CONTINUE + 30 CONTINUE + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSTEIN', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( N.EQ.0 .OR. M.EQ.0 ) THEN + RETURN + ELSE IF( N.EQ.1 ) THEN + Z( 1, 1 ) = ONE + RETURN + END IF +* +* GET MACHINE CONSTANTS. +* + EPS = DLAMCH( 'PRECISION' ) +* +* INITIALIZE SEED FOR RANDOM NUMBER GENERATOR DLARNV. +* + DO 40 I = 1, 4 + ISEED( I ) = 1 + 40 CONTINUE +* +* INITIALIZE POINTERS. +* + INDRV1 = 0 + INDRV2 = INDRV1 + N + INDRV3 = INDRV2 + N + INDRV4 = INDRV3 + N + INDRV5 = INDRV4 + N +* +* COMPUTE EIGENVECTORS OF MATRIX BLOCKS. +* + GPIND = 1 + J1 = 1 + DO 160 NBLK = 1, IBLOCK( M ) +* +* FIND STARTING AND ENDING INDICES OF BLOCK NBLK. +* + IF( NBLK.EQ.1 ) THEN + B1 = 1 + ELSE + B1 = ISPLIT( NBLK-1 ) + 1 + END IF + BN = ISPLIT( NBLK ) + BLKSIZ = BN - B1 + 1 + IF( BLKSIZ.EQ.1 ) + $ GO TO 60 +* +* COMPUTE REORTHOGONALIZATION CRITERION AND STOPPING CRITERION. +* + ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) ) + ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) ) + DO 50 I = B1 + 1, BN - 1 + ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+ + $ ABS( E( I ) ) ) + 50 CONTINUE + ORTOL = ODM3*ONENRM +* + DTPCRT = SQRT( ODM1 / BLKSIZ ) +* +* LOOP THROUGH EIGENVALUES OF BLOCK NBLK. +* + 60 CONTINUE + JBLK = 0 + DO 150 J = J1, M + IF( IBLOCK( J ).NE.NBLK ) THEN + J1 = J + GO TO 160 + END IF + JBLK = JBLK + 1 + XJ = W( J ) +* +* SKIP ALL THE WORK IF THE BLOCK SIZE IS ONE. +* + IF( BLKSIZ.EQ.1 ) THEN + WORK( INDRV1+1 ) = ONE + GO TO 120 + END IF +* +* IF EIGENVALUES J AND J-1 ARE TOO CLOSE, ADD A RELATIVELY +* SMALL PERTURBATION. +* + IF( JBLK.GT.1 ) THEN + EPS1 = ABS( EPS*XJ ) + PERTOL = TEN*EPS1 + SEP = XJ - XJM + IF( SEP.LT.PERTOL ) + $ XJ = XJM + PERTOL + END IF +* + ITS = 0 + NRMCHK = 0 +* +* GET RANDOM STARTING VECTOR. +* + CALL DLARNV( 3, ISEED, BLKSIZ, WORK( INDRV1+1 ) ) +* +* COPY THE MATRIX T SO IT WON'T BE DESTROYED IN FACTORIZATION. +* + CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 ) + CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 ) + CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 ) +* +* COMPUTE LU FACTORS WITH PARTIAL PIVOTING ( PT = LU ) +* + TOL = ZERO + CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ), + $ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK, + $ IINFO ) +* +* UPDATE ITERATION COUNT. +* + 70 CONTINUE + ITS = ITS + 1 + IF( ITS.GT.MAXITS ) + $ GO TO 100 +* +* NORMALIZE AND SCALE THE RIGHTHAND SIDE VECTOR PB. +* + SCL = BLKSIZ*ONENRM*MAX( EPS, + $ ABS( WORK( INDRV4+BLKSIZ ) ) ) / + $ DASUM( BLKSIZ, WORK( INDRV1+1 ), 1 ) + CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) +* +* SOLVE THE SYSTEM LU = PB. +* + CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ), + $ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK, + $ WORK( INDRV1+1 ), TOL, IINFO ) +* +* REORTHOGONALIZE BY MODIFIED GRAM-SCHMIDT IF EIGENVALUES ARE +* CLOSE ENOUGH. +* + IF( JBLK.EQ.1 ) + $ GO TO 90 + IF( ABS( XJ-XJM ).GT.ORTOL ) + $ GPIND = J + IF( GPIND.NE.J ) THEN + DO 80 I = GPIND, J - 1 + ZTR = -DDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ), + $ 1 ) + CALL DAXPY( BLKSIZ, ZTR, Z( B1, I ), 1, + $ WORK( INDRV1+1 ), 1 ) + 80 CONTINUE + END IF +* +* CHECK THE INFINITY NORM OF THE ITERATE. +* + 90 CONTINUE + JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) + NRM = ABS( WORK( INDRV1+JMAX ) ) +* +* CONTINUE FOR ADDITIONAL ITERATIONS AFTER NORM REACHES +* STOPPING CRITERION. +* + IF( NRM.LT.DTPCRT ) + $ GO TO 70 + NRMCHK = NRMCHK + 1 + IF( NRMCHK.LT.EXTRA+1 ) + $ GO TO 70 +* + GO TO 110 +* +* IF STOPPING CRITERION WAS NOT SATISFIED, UPDATE INFO AND +* STORE EIGENVECTOR NUMBER IN ARRAY IFAIL. +* + 100 CONTINUE + INFO = INFO + 1 + IFAIL( INFO ) = J +* +* ACCEPT ITERATE AS JTH EIGENVECTOR. +* + 110 CONTINUE + SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 ) + JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) + IF( WORK( INDRV1+JMAX ).LT.ZERO ) + $ SCL = -SCL + CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) + 120 CONTINUE + DO 130 I = 1, N + Z( I, J ) = ZERO + 130 CONTINUE + DO 140 I = 1, BLKSIZ + Z( B1+I-1, J ) = WORK( INDRV1+I ) + 140 CONTINUE +* +* SAVE THE SHIFT TO CHECK EIGENVALUE SPACING AT NEXT +* ITERATION. +* + XJM = XJ +* + 150 CONTINUE + 160 CONTINUE +* + RETURN +* +* END OF DSTEIN +* + END +CUT HERE............ +CAT > DLAGTS.F <<'CUT HERE............' + SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + INTEGER INFO, JOB, N + DOUBLE PRECISION TOL +* .. +* .. ARRAY ARGUMENTS .. + INTEGER IN( * ) + DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ), Y( * ) +* .. +* +* PURPOSE +* ======= +* +* DLAGTS MAY BE USED TO SOLVE ONE OF THE SYSTEMS OF EQUATIONS +* +* (T - LAMBDA*I)*X = Y OR (T - LAMBDA*I)'*X = Y, +* +* WHERE T IS AN N BY N TRIDIAGONAL MATRIX, FOR X, FOLLOWING THE +* FACTORIZATION OF (T - LAMBDA*I) AS +* +* (T - LAMBDA*I) = P*L*U , +* +* BY ROUTINE DLAGTF. THE CHOICE OF EQUATION TO BE SOLVED IS +* CONTROLLED BY THE ARGUMENT JOB, AND IN EACH CASE THERE IS AN OPTION +* TO PERTURB ZERO OR VERY SMALL DIAGONAL ELEMENTS OF U, THIS OPTION +* BEING INTENDED FOR USE IN APPLICATIONS SUCH AS INVERSE ITERATION. +* +* ARGUMENTS +* ========= +* +* JOB (INPUT) INTEGER +* SPECIFIES THE JOB TO BE PERFORMED BY DLAGTS AS FOLLOWS: +* = 1: THE EQUATIONS (T - LAMBDA*I)X = Y ARE TO BE SOLVED, +* BUT DIAGONAL ELEMENTS OF U ARE NOT TO BE PERTURBED. +* = -1: THE EQUATIONS (T - LAMBDA*I)X = Y ARE TO BE SOLVED +* AND, IF OVERFLOW WOULD OTHERWISE OCCUR, THE DIAGONAL +* ELEMENTS OF U ARE TO BE PERTURBED. SEE ARGUMENT TOL +* BELOW. +* = 2: THE EQUATIONS (T - LAMBDA*I)'X = Y ARE TO BE SOLVED, +* BUT DIAGONAL ELEMENTS OF U ARE NOT TO BE PERTURBED. +* = -2: THE EQUATIONS (T - LAMBDA*I)'X = Y ARE TO BE SOLVED +* AND, IF OVERFLOW WOULD OTHERWISE OCCUR, THE DIAGONAL +* ELEMENTS OF U ARE TO BE PERTURBED. SEE ARGUMENT TOL +* BELOW. +* +* N (INPUT) INTEGER +* THE ORDER OF THE MATRIX T. +* +* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* ON ENTRY, A MUST CONTAIN THE DIAGONAL ELEMENTS OF U AS +* RETURNED FROM DLAGTF. +* +* B (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) +* ON ENTRY, B MUST CONTAIN THE FIRST SUPER-DIAGONAL ELEMENTS OF +* U AS RETURNED FROM DLAGTF. +* +* C (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) +* ON ENTRY, C MUST CONTAIN THE SUB-DIAGONAL ELEMENTS OF L AS +* RETURNED FROM DLAGTF. +* +* D (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-2) +* ON ENTRY, D MUST CONTAIN THE SECOND SUPER-DIAGONAL ELEMENTS +* OF U AS RETURNED FROM DLAGTF. +* +* IN (INPUT) INTEGER ARRAY, DIMENSION (N) +* ON ENTRY, IN MUST CONTAIN DETAILS OF THE MATRIX P AS RETURNED +* FROM DLAGTF. +* +* Y (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* ON ENTRY, THE RIGHT HAND SIDE VECTOR Y. +* +* ON EXIT, Y IS OVERWRITTEN BY THE SOLUTION VECTOR X. +* +* TOL (INPUT/OUTPUT) DOUBLE PRECISION +* ON ENTRY WITH JOB .LT. 0, TOL SHOULD BE THE MINIMUM +* PERTURBATION TO BE MADE TO VERY SMALL DIAGONAL ELEMENTS OF U. +* TOL SHOULD NORMALLY BE CHOSEN AS ABOUT EPS*NORM(U), WHERE EPS +* IS THE RELATIVE MACHINE PRECISION, BUT IF TOL IS SUPPLIED AS +* NON-POSITIVE, THEN IT IS RESET TO EPS*MAX( ABS( U(I,J) ) ). +* IF JOB .GT. 0 THEN TOL IS NOT REFERENCED. +* +* ON EXIT, TOL IS CHANGED AS DESCRIBED ABOVE, ONLY IF TOL IS +* NON-POSITIVE ON ENTRY. OTHERWISE TOL IS UNCHANGED. +* +* INFO (OUTPUT) +* = 0 : SUCCESSFUL EXIT +* .LT. 0: IF INFO = -K, THE KTH ARGUMENT HAD AN ILLEGAL VALUE +* .GT. 0: OVERFLOW WOULD OCCUR WHEN COMPUTING THE INFO(TH) +* ELEMENT OF THE SOLUTION VECTOR X. THIS CAN ONLY OCCUR +* WHEN JOB IS SUPPLIED AS POSITIVE AND EITHER MEANS +* THAT A DIAGONAL ELEMENT OF U IS VERY SMALL, OR THAT +* THE ELEMENTS OF THE RIGHT-HAND SIDE VECTOR Y ARE VERY +* LARGE. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER K + DOUBLE PRECISION ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS, MAX, SIGN +* .. +* .. EXTERNAL FUNCTIONS .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. +* .. EXECUTABLE STATEMENTS .. +* + INFO = 0 + IF( ( ABS( JOB ).GT.2 ) .OR. ( JOB.EQ.0 ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAGTS', -INFO ) + RETURN + END IF +* + IF( N.EQ.0 ) + $ RETURN +* + EPS = DLAMCH( 'EPSILON' ) + SFMIN = DLAMCH( 'SAFE MINIMUM' ) + BIGNUM = ONE / SFMIN +* + IF( JOB.LT.0 ) THEN + IF( TOL.LE.ZERO ) THEN + TOL = ABS( A( 1 ) ) + IF( N.GT.1 ) + $ TOL = MAX( TOL, ABS( A( 2 ) ), ABS( B( 1 ) ) ) + DO 10 K = 3, N + TOL = MAX( TOL, ABS( A( K ) ), ABS( B( K-1 ) ), + $ ABS( D( K-2 ) ) ) + 10 CONTINUE + TOL = TOL*EPS + IF( TOL.EQ.ZERO ) + $ TOL = EPS + END IF + END IF +* + IF( ABS( JOB ).EQ.1 ) THEN + DO 20 K = 2, N + IF( IN( K-1 ).EQ.0 ) THEN + Y( K ) = Y( K ) - C( K-1 )*Y( K-1 ) + ELSE + TEMP = Y( K-1 ) + Y( K-1 ) = Y( K ) + Y( K ) = TEMP - C( K-1 )*Y( K ) + END IF + 20 CONTINUE + IF( JOB.EQ.1 ) THEN + DO 30 K = N, 1, -1 + IF( K.LE.N-2 ) THEN + TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 ) + ELSE IF( K.EQ.N-1 ) THEN + TEMP = Y( K ) - B( K )*Y( K+1 ) + ELSE + TEMP = Y( K ) + END IF + AK = A( K ) + ABSAK = ABS( AK ) + IF( ABSAK.LT.ONE ) THEN + IF( ABSAK.LT.SFMIN ) THEN + IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) + $ THEN + INFO = K + RETURN + ELSE + TEMP = TEMP*BIGNUM + AK = AK*BIGNUM + END IF + ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN + INFO = K + RETURN + END IF + END IF + Y( K ) = TEMP / AK + 30 CONTINUE + ELSE + DO 50 K = N, 1, -1 + IF( K.LE.N-2 ) THEN + TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 ) + ELSE IF( K.EQ.N-1 ) THEN + TEMP = Y( K ) - B( K )*Y( K+1 ) + ELSE + TEMP = Y( K ) + END IF + AK = A( K ) + PERT = SIGN( TOL, AK ) + 40 CONTINUE + ABSAK = ABS( AK ) + IF( ABSAK.LT.ONE ) THEN + IF( ABSAK.LT.SFMIN ) THEN + IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) + $ THEN + AK = AK + PERT + PERT = 2*PERT + GO TO 40 + ELSE + TEMP = TEMP*BIGNUM + AK = AK*BIGNUM + END IF + ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN + AK = AK + PERT + PERT = 2*PERT + GO TO 40 + END IF + END IF + Y( K ) = TEMP / AK + 50 CONTINUE + END IF + ELSE +* +* COME TO HERE IF JOB = 2 OR -2 +* + IF( JOB.EQ.2 ) THEN + DO 60 K = 1, N + IF( K.GE.3 ) THEN + TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 ) + ELSE IF( K.EQ.2 ) THEN + TEMP = Y( K ) - B( K-1 )*Y( K-1 ) + ELSE + TEMP = Y( K ) + END IF + AK = A( K ) + ABSAK = ABS( AK ) + IF( ABSAK.LT.ONE ) THEN + IF( ABSAK.LT.SFMIN ) THEN + IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) + $ THEN + INFO = K + RETURN + ELSE + TEMP = TEMP*BIGNUM + AK = AK*BIGNUM + END IF + ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN + INFO = K + RETURN + END IF + END IF + Y( K ) = TEMP / AK + 60 CONTINUE + ELSE + DO 80 K = 1, N + IF( K.GE.3 ) THEN + TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 ) + ELSE IF( K.EQ.2 ) THEN + TEMP = Y( K ) - B( K-1 )*Y( K-1 ) + ELSE + TEMP = Y( K ) + END IF + AK = A( K ) + PERT = SIGN( TOL, AK ) + 70 CONTINUE + ABSAK = ABS( AK ) + IF( ABSAK.LT.ONE ) THEN + IF( ABSAK.LT.SFMIN ) THEN + IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK ) + $ THEN + AK = AK + PERT + PERT = 2*PERT + GO TO 70 + ELSE + TEMP = TEMP*BIGNUM + AK = AK*BIGNUM + END IF + ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN + AK = AK + PERT + PERT = 2*PERT + GO TO 70 + END IF + END IF + Y( K ) = TEMP / AK + 80 CONTINUE + END IF +* + DO 90 K = N, 2, -1 + IF( IN( K-1 ).EQ.0 ) THEN + Y( K-1 ) = Y( K-1 ) - C( K-1 )*Y( K ) + ELSE + TEMP = Y( K-1 ) + Y( K-1 ) = Y( K ) + Y( K ) = TEMP - C( K-1 )*Y( K ) + END IF + 90 CONTINUE + END IF +* +* END OF DLAGTS +* + END +CUT HERE............ +CAT > DLAGTF.F <<'CUT HERE............' + SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + INTEGER INFO, N + DOUBLE PRECISION LAMBDA, TOL +* .. +* .. ARRAY ARGUMENTS .. + INTEGER IN( * ) + DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ) +* .. +* +* PURPOSE +* ======= +* +* DLAGTF FACTORIZES THE MATRIX (T - LAMBDA*I), WHERE T IS AN N BY N +* TRIDIAGONAL MATRIX AND LAMBDA IS A SCALAR, AS +* +* T - LAMBDA*I = PLU, +* +* WHERE P IS A PERMUTATION MATRIX, L IS A UNIT LOWER TRIDIAGONAL MATRIX +* WITH AT MOST ONE NON-ZERO SUB-DIAGONAL ELEMENTS PER COLUMN AND U IS +* AN UPPER TRIANGULAR MATRIX WITH AT MOST TWO NON-ZERO SUPER-DIAGONAL +* ELEMENTS PER COLUMN. +* +* THE FACTORIZATION IS OBTAINED BY GAUSSIAN ELIMINATION WITH PARTIAL +* PIVOTING AND IMPLICIT ROW SCALING. +* +* THE PARAMETER LAMBDA IS INCLUDED IN THE ROUTINE SO THAT DLAGTF MAY +* BE USED, IN CONJUNCTION WITH DLAGTS, TO OBTAIN EIGENVECTORS OF T BY +* INVERSE ITERATION. +* +* ARGUMENTS +* ========= +* +* N (INPUT) INTEGER +* THE ORDER OF THE MATRIX T. +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* ON ENTRY, A MUST CONTAIN THE DIAGONAL ELEMENTS OF T. +* +* ON EXIT, A IS OVERWRITTEN BY THE N DIAGONAL ELEMENTS OF THE +* UPPER TRIANGULAR MATRIX U OF THE FACTORIZATION OF T. +* +* LAMBDA (INPUT) DOUBLE PRECISION +* ON ENTRY, THE SCALAR LAMBDA. +* +* B (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) +* ON ENTRY, B MUST CONTAIN THE (N-1) SUPER-DIAGONAL ELEMENTS OF +* T. +* +* ON EXIT, B IS OVERWRITTEN BY THE (N-1) SUPER-DIAGONAL +* ELEMENTS OF THE MATRIX U OF THE FACTORIZATION OF T. +* +* C (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) +* ON ENTRY, C MUST CONTAIN THE (N-1) SUB-DIAGONAL ELEMENTS OF +* T. +* +* ON EXIT, C IS OVERWRITTEN BY THE (N-1) SUB-DIAGONAL ELEMENTS +* OF THE MATRIX L OF THE FACTORIZATION OF T. +* +* TOL (INPUT) DOUBLE PRECISION +* ON ENTRY, A RELATIVE TOLERANCE USED TO INDICATE WHETHER OR +* NOT THE MATRIX (T - LAMBDA*I) IS NEARLY SINGULAR. TOL SHOULD +* NORMALLY BE CHOSE AS APPROXIMATELY THE LARGEST RELATIVE ERROR +* IN THE ELEMENTS OF T. FOR EXAMPLE, IF THE ELEMENTS OF T ARE +* CORRECT TO ABOUT 4 SIGNIFICANT FIGURES, THEN TOL SHOULD BE +* SET TO ABOUT 5*10**(-4). IF TOL IS SUPPLIED AS LESS THAN EPS, +* WHERE EPS IS THE RELATIVE MACHINE PRECISION, THEN THE VALUE +* EPS IS USED IN PLACE OF TOL. +* +* D (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-2) +* ON EXIT, D IS OVERWRITTEN BY THE (N-2) SECOND SUPER-DIAGONAL +* ELEMENTS OF THE MATRIX U OF THE FACTORIZATION OF T. +* +* IN (OUTPUT) INTEGER ARRAY, DIMENSION (N) +* ON EXIT, IN CONTAINS DETAILS OF THE PERMUTATION MATRIX P. IF +* AN INTERCHANGE OCCURRED AT THE KTH STEP OF THE ELIMINATION, +* THEN IN(K) = 1, OTHERWISE IN(K) = 0. THE ELEMENT IN(N) +* RETURNS THE SMALLEST POSITIVE INTEGER J SUCH THAT +* +* ABS( U(J,J) ).LE. NORM( (T - LAMBDA*I)(J) )*TOL, +* +* WHERE NORM( A(J) ) DENOTES THE SUM OF THE ABSOLUTE VALUES OF +* THE JTH ROW OF THE MATRIX A. IF NO SUCH J EXISTS THEN IN(N) +* IS RETURNED AS ZERO. IF IN(N) IS RETURNED AS POSITIVE, THEN A +* DIAGONAL ELEMENT OF U IS SMALL, INDICATING THAT +* (T - LAMBDA*I) IS SINGULAR OR NEARLY SINGULAR, +* +* INFO (OUTPUT) +* = 0 : SUCCESSFUL EXIT +* .LT. 0: IF INFO = -K, THE KTH ARGUMENT HAD AN ILLEGAL VALUE +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER K + DOUBLE PRECISION EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS, MAX +* .. +* .. EXTERNAL FUNCTIONS .. + DOUBLE PRECISION DLAMCH + EXTERNAL DLAMCH +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. +* .. EXECUTABLE STATEMENTS .. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + CALL XERBLA( 'DLAGTF', -INFO ) + RETURN + END IF +* + IF( N.EQ.0 ) + $ RETURN +* + A( 1 ) = A( 1 ) - LAMBDA + IN( N ) = 0 + IF( N.EQ.1 ) THEN + IF( A( 1 ).EQ.ZERO ) + $ IN( 1 ) = 1 + RETURN + END IF +* + EPS = DLAMCH( 'EPSILON' ) +* + TL = MAX( TOL, EPS ) + SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) ) + DO 10 K = 1, N - 1 + A( K+1 ) = A( K+1 ) - LAMBDA + SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) ) + IF( K.LT.( N-1 ) ) + $ SCALE2 = SCALE2 + ABS( B( K+1 ) ) + IF( A( K ).EQ.ZERO ) THEN + PIV1 = ZERO + ELSE + PIV1 = ABS( A( K ) ) / SCALE1 + END IF + IF( C( K ).EQ.ZERO ) THEN + IN( K ) = 0 + PIV2 = ZERO + SCALE1 = SCALE2 + IF( K.LT.( N-1 ) ) + $ D( K ) = ZERO + ELSE + PIV2 = ABS( C( K ) ) / SCALE2 + IF( PIV2.LE.PIV1 ) THEN + IN( K ) = 0 + SCALE1 = SCALE2 + C( K ) = C( K ) / A( K ) + A( K+1 ) = A( K+1 ) - C( K )*B( K ) + IF( K.LT.( N-1 ) ) + $ D( K ) = ZERO + ELSE + IN( K ) = 1 + MULT = A( K ) / C( K ) + A( K ) = C( K ) + TEMP = A( K+1 ) + A( K+1 ) = B( K ) - MULT*TEMP + IF( K.LT.( N-1 ) ) THEN + D( K ) = B( K+1 ) + B( K+1 ) = -MULT*D( K ) + END IF + B( K ) = TEMP + C( K ) = MULT + END IF + END IF + IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) ) + $ IN( N ) = K + 10 CONTINUE + IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) ) + $ IN( N ) = N +* + RETURN +* +* END OF DLAGTF +* + END +CUT HERE............ +CAT > DLARNV.F <<'CUT HERE............' + SUBROUTINE DLARNV( IDIST, ISEED, N, X ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + INTEGER IDIST, N +* .. +* .. ARRAY ARGUMENTS .. + INTEGER ISEED( 4 ) + DOUBLE PRECISION X( * ) +* .. +* +* PURPOSE +* ======= +* +* DLARNV RETURNS A VECTOR OF N RANDOM REAL NUMBERS FROM A UNIFORM OR +* NORMAL DISTRIBUTION. +* +* ARGUMENTS +* ========= +* +* IDIST (INPUT) INTEGER +* SPECIFIES THE DISTRIBUTION OF THE RANDOM NUMBERS: +* = 1: UNIFORM (0,1) +* = 2: UNIFORM (-1,1) +* = 3: NORMAL (0,1) +* +* ISEED (INPUT/OUTPUT) INTEGER ARRAY, DIMENSION (4) +* ON ENTRY, THE SEED OF THE RANDOM NUMBER GENERATOR; THE ARRAY +* ELEMENTS MUST BE BETWEEN 0 AND 4095, AND ISEED(4) MUST BE +* ODD. +* ON EXIT, THE SEED IS UPDATED. +* +* N (INPUT) INTEGER +* THE NUMBER OF RANDOM NUMBERS TO BE GENERATED. +* +* X (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* THE GENERATED RANDOM NUMBERS. +* +* FURTHER DETAILS +* =============== +* +* THIS ROUTINE CALLS THE AUXILIARY ROUTINE DLARUV TO GENERATE RANDOM +* REAL NUMBERS FROM A UNIFORM (0,1) DISTRIBUTION, IN BATCHES OF UP TO +* 128 USING VECTORISABLE CODE. THE BOX-MULLER METHOD IS USED TO +* TRANSFORM NUMBERS FROM A UNIFORM TO A NORMAL DISTRIBUTION. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE, TWO + PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 ) + INTEGER LV + PARAMETER ( LV = 128 ) + DOUBLE PRECISION TWOPI + PARAMETER ( TWOPI = 6.28318530717958623199592D+0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER I, IL, IL2, IV +* .. +* .. LOCAL ARRAYS .. + DOUBLE PRECISION U( LV ) +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC COS, LOG, MIN, SQRT +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLARUV +* .. +* .. EXECUTABLE STATEMENTS .. +* + DO 40 IV = 1, N, LV / 2 + IL = MIN( LV / 2, N-IV+1 ) + IF( IDIST.EQ.3 ) THEN + IL2 = 2*IL + ELSE + IL2 = IL + END IF +* +* CALL DLARUV TO GENERATE IL2 NUMBERS FROM A UNIFORM (0,1) +* DISTRIBUTION (IL2 <= LV) +* + CALL DLARUV( ISEED, IL2, U ) +* + IF( IDIST.EQ.1 ) THEN +* +* COPY GENERATED NUMBERS +* + DO 10 I = 1, IL + X( IV+I-1 ) = U( I ) + 10 CONTINUE + ELSE IF( IDIST.EQ.2 ) THEN +* +* CONVERT GENERATED NUMBERS TO UNIFORM (-1,1) DISTRIBUTION +* + DO 20 I = 1, IL + X( IV+I-1 ) = TWO*U( I ) - ONE + 20 CONTINUE + ELSE IF( IDIST.EQ.3 ) THEN +* +* CONVERT GENERATED NUMBERS TO NORMAL (0,1) DISTRIBUTION +* + DO 30 I = 1, IL + X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )* + $ COS( TWOPI*U( 2*I ) ) + 30 CONTINUE + END IF + 40 CONTINUE + RETURN +* +* END OF DLARNV +* + END +CUT HERE............ +CAT > DLARUV.F <<'CUT HERE............' + SUBROUTINE DLARUV( ISEED, N, X ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + INTEGER N +* .. +* .. ARRAY ARGUMENTS .. + INTEGER ISEED( 4 ) + DOUBLE PRECISION X( N ) +* .. +* +* PURPOSE +* ======= +* +* DLARUV RETURNS A VECTOR OF N RANDOM REAL NUMBERS FROM A UNIFORM (0,1) +* DISTRIBUTION (N <= 128). +* +* THIS IS AN AUXILIARY ROUTINE CALLED BY DLARNV AND ZLARNV. +* +* ARGUMENTS +* ========= +* +* ISEED (INPUT/OUTPUT) INTEGER ARRAY, DIMENSION (4) +* ON ENTRY, THE SEED OF THE RANDOM NUMBER GENERATOR; THE ARRAY +* ELEMENTS MUST BE BETWEEN 0 AND 4095, AND ISEED(4) MUST BE +* ODD. +* ON EXIT, THE SEED IS UPDATED. +* +* N (INPUT) INTEGER +* THE NUMBER OF RANDOM NUMBERS TO BE GENERATED. N <= 128. +* +* X (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* THE GENERATED RANDOM NUMBERS. +* +* FURTHER DETAILS +* =============== +* +* THIS ROUTINE USES A MULTIPLICATIVE CONGRUENTIAL METHOD WITH MODULUS +* 2**48 AND MULTIPLIER 33952834046453 (SEE G.S.FISHMAN, +* 'MULTIPLICATIVE CONGRUENTIAL RANDOM NUMBER GENERATORS WITH MODULUS +* 2**B: AN EXHAUSTIVE ANALYSIS FOR B = 32 AND A PARTIAL ANALYSIS FOR +* B = 48', MATH. COMP. 189, PP 331-344, 1990). +* +* 48-BIT INTEGERS ARE STORED IN 4 INTEGER ARRAY ELEMENTS WITH 12 BITS +* PER ELEMENT. HENCE THE ROUTINE IS PORTABLE ACROSS MACHINES WITH +* INTEGERS OF 32 BITS OR MORE. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + INTEGER LV, IPW2 + DOUBLE PRECISION R + PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 ) +* .. +* .. LOCAL SCALARS .. + INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J +* .. +* .. LOCAL ARRAYS .. + INTEGER MM( LV, 4 ) +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC DBLE, MIN, MOD +* .. +* .. DATA STATEMENTS .. + DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508, + $ 2549 / + DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754, + $ 1145 / + DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766, + $ 2253 / + DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572, + $ 305 / + DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893, + $ 3301 / + DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307, + $ 1065 / + DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297, + $ 3133 / + DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966, + $ 2913 / + DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758, + $ 3285 / + DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598, + $ 1241 / + DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406, + $ 1197 / + DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922, + $ 3729 / + DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038, + $ 2501 / + DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934, + $ 1673 / + DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091, + $ 541 / + DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451, + $ 2753 / + DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580, + $ 949 / + DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958, + $ 2361 / + DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055, + $ 1165 / + DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507, + $ 4081 / + DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078, + $ 2725 / + DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273, + $ 3305 / + DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17, + $ 3069 / + DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854, + $ 3617 / + DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916, + $ 3733 / + DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971, + $ 409 / + DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889, + $ 2157 / + DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831, + $ 1361 / + DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621, + $ 3973 / + DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541, + $ 1865 / + DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893, + $ 2525 / + DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736, + $ 1409 / + DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992, + $ 3445 / + DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787, + $ 3577 / + DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125, + $ 77 / + DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364, + $ 3761 / + DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460, + $ 2149 / + DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257, + $ 1449 / + DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574, + $ 3005 / + DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912, + $ 225 / + DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216, + $ 85 / + DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248, + $ 3673 / + DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401, + $ 3117 / + DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124, + $ 3089 / + DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762, + $ 1349 / + DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149, + $ 2057 / + DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245, + $ 413 / + DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166, + $ 65 / + DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466, + $ 1845 / + DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018, + $ 697 / + DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399, + $ 3085 / + DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190, + $ 3441 / + DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879, + $ 1573 / + DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153, + $ 3689 / + DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320, + $ 2941 / + DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18, + $ 929 / + DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712, + $ 533 / + DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159, + $ 2841 / + DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318, + $ 4077 / + DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091, + $ 721 / + DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443, + $ 2821 / + DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510, + $ 2249 / + DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449, + $ 2397 / + DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956, + $ 2817 / + DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201, + $ 245 / + DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137, + $ 1913 / + DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399, + $ 1997 / + DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321, + $ 3121 / + DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271, + $ 997 / + DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667, + $ 1833 / + DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703, + $ 2877 / + DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629, + $ 1633 / + DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365, + $ 981 / + DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431, + $ 2009 / + DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113, + $ 941 / + DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922, + $ 2449 / + DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554, + $ 197 / + DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184, + $ 2441 / + DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099, + $ 285 / + DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228, + $ 1473 / + DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012, + $ 2741 / + DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921, + $ 3129 / + DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452, + $ 909 / + DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901, + $ 2801 / + DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572, + $ 421 / + DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309, + $ 4073 / + DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171, + $ 2813 / + DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817, + $ 2337 / + DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039, + $ 1429 / + DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696, + $ 1177 / + DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256, + $ 1901 / + DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715, + $ 81 / + DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077, + $ 1669 / + DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019, + $ 2633 / + DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497, + $ 2269 / + DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101, + $ 129 / + DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717, + $ 1141 / + DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51, + $ 249 / + DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981, + $ 3917 / + DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978, + $ 2481 / + DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813, + $ 3941 / + DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881, + $ 2217 / + DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76, + $ 2749 / + DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846, + $ 3041 / + DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694, + $ 1877 / + DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682, + $ 345 / + DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124, + $ 2861 / + DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660, + $ 1809 / + DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997, + $ 3141 / + DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479, + $ 2825 / + DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141, + $ 157 / + DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886, + $ 2881 / + DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514, + $ 3637 / + DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301, + $ 1465 / + DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604, + $ 2829 / + DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888, + $ 2161 / + DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836, + $ 3365 / + DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990, + $ 361 / + DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058, + $ 2685 / + DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692, + $ 3745 / + DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194, + $ 2325 / + DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20, + $ 3609 / + DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285, + $ 3821 / + DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046, + $ 3537 / + DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107, + $ 517 / + DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508, + $ 3017 / + DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525, + $ 2141 / + DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801, + $ 1537 / +* .. +* .. EXECUTABLE STATEMENTS .. +* + I1 = ISEED( 1 ) + I2 = ISEED( 2 ) + I3 = ISEED( 3 ) + I4 = ISEED( 4 ) +* + DO 10 I = 1, MIN( N, LV ) +* +* MULTIPLY THE SEED BY I-TH POWER OF THE MULTIPLIER MODULO 2**48 +* + IT4 = I4*MM( I, 4 ) + IT3 = IT4 / IPW2 + IT4 = IT4 - IPW2*IT3 + IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 ) + IT2 = IT3 / IPW2 + IT3 = IT3 - IPW2*IT2 + IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 ) + IT1 = IT2 / IPW2 + IT2 = IT2 - IPW2*IT1 + IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) + + $ I4*MM( I, 1 ) + IT1 = MOD( IT1, IPW2 ) +* +* CONVERT 48-BIT INTEGER TO A REAL NUMBER IN THE INTERVAL (0,1) +* + X( I ) = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R* + $ DBLE( IT4 ) ) ) ) + 10 CONTINUE +* +* RETURN FINAL VALUE OF SEED +* + ISEED( 1 ) = IT1 + ISEED( 2 ) = IT2 + ISEED( 3 ) = IT3 + ISEED( 4 ) = IT4 + RETURN +* +* END OF DLARUV +* + END +CUT HERE............ +CAT > DSTEBZ.F <<'CUT HERE............' + SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E, + $ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK, + $ INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* MARCH 31, 1993 +* +* .. SCALAR ARGUMENTS .. + CHARACTER ORDER, RANGE + INTEGER IL, INFO, IU, M, N, NSPLIT + DOUBLE PRECISION ABSTOL, VL, VU +* .. +* .. ARRAY ARGUMENTS .. + INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ) +* .. +* +* PURPOSE +* ======= +* +* DSTEBZ COMPUTES THE EIGENVALUES OF A SYMMETRIC TRIDIAGONAL +* MATRIX T. THE USER MAY ASK FOR ALL EIGENVALUES, ALL EIGENVALUES +* IN THE HALF-OPEN INTERVAL (VL, VU], OR THE IL-TH THROUGH IU-TH +* EIGENVALUES. +* +* SEE W. KAHAN "ACCURATE EIGENVALUES OF A SYMMETRIC TRIDIAGONAL +* MATRIX", REPORT CS41, COMPUTER SCIENCE DEPT., STANFORD +* UNIVERSITY, JULY 21, 1966. +* +* ARGUMENTS +* ========= +* +* RANGE (INPUT) CHARACTER +* = 'A': ("ALL") ALL EIGENVALUES WILL BE FOUND. +* = 'V': ("VALUE") ALL EIGENVALUES IN THE HALF-OPEN INTERVAL +* (VL, VU] WILL BE FOUND. +* = 'I': ("INDEX") THE IL-TH THROUGH IU-TH EIGENVALUES (OF THE +* ENTIRE MATRIX) WILL BE FOUND. +* +* ORDER (INPUT) CHARACTER +* = 'B': ("BY BLOCK") THE EIGENVALUES WILL BE GROUPED BY +* SPLIT-OFF BLOCK (SEE IBLOCK, ISPLIT) AND +* ORDERED FROM SMALLEST TO LARGEST WITHIN +* THE BLOCK. +* = 'E': ("ENTIRE MATRIX") +* THE EIGENVALUES FOR THE ENTIRE MATRIX +* WILL BE ORDERED FROM SMALLEST TO +* LARGEST. +* +* N (INPUT) INTEGER +* THE DIMENSION OF THE TRIDIAGONAL MATRIX T. N >= 0. +* +* VL (INPUT) DOUBLE PRECISION +* IF RANGE='V', THE LOWER BOUND OF THE INTERVAL TO BE SEARCHED +* FOR EIGENVALUES. EIGENVALUES LESS THAN OR EQUAL TO VL WILL +* NOT BE RETURNED. NOT REFERENCED IF RANGE='A' OR 'I'. +* +* VU (INPUT) DOUBLE PRECISION +* IF RANGE='V', THE UPPER BOUND OF THE INTERVAL TO BE SEARCHED +* FOR EIGENVALUES. EIGENVALUES GREATER THAN VU WILL NOT BE +* RETURNED. VU MUST BE GREATER THAN VL. NOT REFERENCED IF +* RANGE='A' OR 'I'. +* +* IL (INPUT) INTEGER +* IF RANGE='I', THE INDEX (FROM SMALLEST TO LARGEST) OF THE +* SMALLEST EIGENVALUE TO BE RETURNED. IL MUST BE AT LEAST 1. +* NOT REFERENCED IF RANGE='A' OR 'V'. +* +* IU (INPUT) INTEGER +* IF RANGE='I', THE INDEX (FROM SMALLEST TO LARGEST) OF THE +* LARGEST EIGENVALUE TO BE RETURNED. IU MUST BE AT LEAST IL +* AND NO GREATER THAN N. NOT REFERENCED IF RANGE='A' OR 'V'. +* +* ABSTOL (INPUT) DOUBLE PRECISION +* THE ABSOLUTE TOLERANCE FOR THE EIGENVALUES. AN EIGENVALUE +* (OR CLUSTER) IS CONSIDERED TO BE LOCATED IF IT HAS BEEN +* DETERMINED TO LIE IN AN INTERVAL WHOSE WIDTH IS ABSTOL OR +* LESS. IF ABSTOL IS LESS THAN OR EQUAL TO ZERO, THEN ULP*|T| +* WILL BE USED, WHERE |T| MEANS THE 1-NORM OF T. +* +* D (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* THE N DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T. TO +* AVOID OVERFLOW, THE MATRIX MUST BE SCALED SO THAT ITS LARGEST +* ENTRY IS NO GREATER THAN OVERFLOW**(1/2) * UNDERFLOW**(1/4) +* IN ABSOLUTE VALUE, AND FOR GREATEST ACCURACY, IT SHOULD NOT +* BE MUCH SMALLER THAN THAT. +* +* E (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) +* THE (N-1) OFF-DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T. +* TO AVOID OVERFLOW, THE MATRIX MUST BE SCALED SO THAT ITS +* LARGEST ENTRY IS NO GREATER THAN OVERFLOW**(1/2) * +* UNDERFLOW**(1/4) IN ABSOLUTE VALUE, AND FOR GREATEST +* ACCURACY, IT SHOULD NOT BE MUCH SMALLER THAN THAT. +* +* M (OUTPUT) INTEGER +* THE ACTUAL NUMBER OF EIGENVALUES FOUND. 0 <= M <= N. +* (SEE ALSO THE DESCRIPTION OF INFO=2,3.) +* +* NSPLIT (OUTPUT) INTEGER +* THE NUMBER OF DIAGONAL BLOCKS IN THE MATRIX T. +* 1 <= NSPLIT <= N. +* +* W (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* ON EXIT, THE FIRST M ELEMENTS OF W WILL CONTAIN THE +* EIGENVALUES. (DSTEBZ MAY USE THE REMAINING N-M ELEMENTS AS +* WORKSPACE.) +* +* IBLOCK (OUTPUT) INTEGER ARRAY, DIMENSION (N) +* AT EACH ROW/COLUMN J WHERE E(J) IS ZERO OR SMALL, THE +* MATRIX T IS CONSIDERED TO SPLIT INTO A BLOCK DIAGONAL +* MATRIX. ON EXIT, IBLOCK(I) SPECIFIES WHICH BLOCK (FROM 1 TO +* THE NUMBER OF BLOCKS) THE EIGENVALUE W(I) BELONGS TO. +* (DSTEBZ MAY USE THE REMAINING N-M ELEMENTS AS WORKSPACE.) +* +* ISPLIT (OUTPUT) INTEGER ARRAY, DIMENSION (N) +* THE SPLITTING POINTS, AT WHICH T BREAKS UP INTO SUBMATRICES. +* THE FIRST SUBMATRIX CONSISTS OF ROWS/COLUMNS 1 TO ISPLIT(1), +* THE SECOND OF ROWS/COLUMNS ISPLIT(1)+1 THROUGH ISPLIT(2), +* ETC., AND THE NSPLIT-TH CONSISTS OF ROWS/COLUMNS +* ISPLIT(NSPLIT-1)+1 THROUGH ISPLIT(NSPLIT)=N. +* (ONLY THE FIRST NSPLIT ELEMENTS WILL ACTUALLY BE USED, BUT +* SINCE THE USER CANNOT KNOW A PRIORI WHAT VALUE NSPLIT WILL +* HAVE, N WORDS MUST BE RESERVED FOR ISPLIT.) +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (4*N) +* +* IWORK (WORKSPACE) INTEGER ARRAY, DIMENSION (3*N) +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE +* > 0: SOME OR ALL OF THE EIGENVALUES FAILED TO CONVERGE OR +* WERE NOT COMPUTED: +* =1 OR 3: BISECTION FAILED TO CONVERGE FOR SOME +* EIGENVALUES; THESE EIGENVALUES ARE FLAGGED BY A +* NEGATIVE BLOCK NUMBER. THE EFFECT IS THAT THE +* EIGENVALUES MAY NOT BE AS ACCURATE AS THE +* ABSOLUTE AND RELATIVE TOLERANCES. THIS IS +* GENERALLY CAUSED BY UNEXPECTEDLY INACCURATE +* ARITHMETIC. +* =2 OR 3: RANGE='I' ONLY: NOT ALL OF THE EIGENVALUES +* IL:IU WERE FOUND. +* EFFECT: M < IU+1-IL +* CAUSE: NON-MONOTONIC ARITHMETIC, CAUSING THE +* STURM SEQUENCE TO BE NON-MONOTONIC. +* CURE: RECALCULATE, USING RANGE='A', AND PICK +* OUT EIGENVALUES IL:IU. IN SOME CASES, +* INCREASING THE PARAMETER "FUDGE" MAY +* MAKE THINGS WORK. +* = 4: RANGE='I', AND THE GERSHGORIN INTERVAL +* INITIALLY USED WAS TOO SMALL. NO EIGENVALUES +* WERE COMPUTED. +* PROBABLE CAUSE: YOUR MACHINE HAS SLOPPY +* FLOATING-POINT ARITHMETIC. +* CURE: INCREASE THE PARAMETER "FUDGE", +* RECOMPILE, AND TRY AGAIN. +* +* INTERNAL PARAMETERS +* =================== +* +* RELFAC DOUBLE PRECISION, DEFAULT = 2.0E0 +* THE RELATIVE TOLERANCE. AN INTERVAL (A,B] LIES WITHIN +* "RELATIVE TOLERANCE" IF B-A < RELFAC*ULP*MAX(|A|,|B|), +* WHERE "ULP" IS THE MACHINE PRECISION (DISTANCE FROM 1 TO +* THE NEXT LARGER FLOATING POINT NUMBER.) +* +* FUDGE DOUBLE PRECISION, DEFAULT = 2 +* A "FUDGE FACTOR" TO WIDEN THE GERSHGORIN INTERVALS. IDEALLY, +* A VALUE OF 1 SHOULD WORK, BUT ON MACHINES WITH SLOPPY +* ARITHMETIC, THIS NEEDS TO BE LARGER. THE DEFAULT FOR +* PUBLICLY RELEASED VERSIONS SHOULD BE LARGE ENOUGH TO HANDLE +* THE WORST MACHINE AROUND. NOTE THAT THIS HAS NO EFFECT +* ON ACCURACY OF THE SOLUTION. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO, ONE, TWO, HALF + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0, + $ HALF = 1.0D0 / TWO ) + DOUBLE PRECISION FUDGE, RELFAC + PARAMETER ( FUDGE = 2.0D0, RELFAC = 2.0D0 ) +* .. +* .. LOCAL SCALARS .. + LOGICAL NCNVRG, TOOFEW + INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO, + $ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX, + $ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL, + $ NWU + DOUBLE PRECISION ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN, + $ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL +* .. +* .. LOCAL ARRAYS .. + INTEGER IDUMMA( 1 ) +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + INTEGER ILAENV + DOUBLE PRECISION DLAMCH + EXTERNAL LSAME, ILAENV, DLAMCH +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLAEBZ, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT +* .. +* .. EXECUTABLE STATEMENTS .. +* + INFO = 0 +* +* DECODE RANGE +* + IF( LSAME( RANGE, 'A' ) ) THEN + IRANGE = 1 + ELSE IF( LSAME( RANGE, 'V' ) ) THEN + IRANGE = 2 + ELSE IF( LSAME( RANGE, 'I' ) ) THEN + IRANGE = 3 + ELSE + IRANGE = 0 + END IF +* +* DECODE ORDER +* + IF( LSAME( ORDER, 'B' ) ) THEN + IORDER = 2 + ELSE IF( LSAME( ORDER, 'E' ) .OR. LSAME( ORDER, 'A' ) ) THEN + IORDER = 1 + ELSE + IORDER = 0 + END IF +* +* CHECK FOR ERRORS +* + IF( IRANGE.LE.0 ) THEN + INFO = -1 + ELSE IF( IORDER.LE.0 ) THEN + INFO = -2 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( IRANGE.EQ.2 .AND. VL.GE.VU ) THEN + INFO = -5 + ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) + $ THEN + INFO = -6 + ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) + $ THEN + INFO = -7 + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSTEBZ', -INFO ) + RETURN + END IF +* +* INITIALIZE ERROR FLAGS +* + INFO = 0 + NCNVRG = .FALSE. + TOOFEW = .FALSE. +* +* QUICK RETURN IF POSSIBLE +* + M = 0 + IF( N.EQ.0 ) + $ RETURN +* +* SIMPLIFICATIONS: +* + IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N ) + $ IRANGE = 1 +* +* GET MACHINE CONSTANTS +* NB IS THE MINIMUM VECTOR LENGTH FOR VECTOR BISECTION, OR 0 +* IF ONLY SCALAR IS TO BE DONE. +* + SAFEMN = DLAMCH( 'S' ) + ULP = DLAMCH( 'P' ) + RTOLI = ULP*RELFAC + NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 ) + IF( NB.LE.1 ) + $ NB = 0 +* +* SPECIAL CASE WHEN N=1 +* + IF( N.EQ.1 ) THEN + NSPLIT = 1 + ISPLIT( 1 ) = 1 + IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN + M = 0 + ELSE + W( 1 ) = D( 1 ) + IBLOCK( 1 ) = 1 + M = 1 + END IF + RETURN + END IF +* +* COMPUTE SPLITTING POINTS +* + NSPLIT = 1 + WORK( N ) = ZERO + PIVMIN = ONE +* + DO 10 J = 2, N + TMP1 = E( J-1 )**2 + IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN + ISPLIT( NSPLIT ) = J - 1 + NSPLIT = NSPLIT + 1 + WORK( J-1 ) = ZERO + ELSE + WORK( J-1 ) = TMP1 + PIVMIN = MAX( PIVMIN, TMP1 ) + END IF + 10 CONTINUE + ISPLIT( NSPLIT ) = N + PIVMIN = PIVMIN*SAFEMN +* +* COMPUTE INTERVAL AND ATOLI +* + IF( IRANGE.EQ.3 ) THEN +* +* RANGE='I': COMPUTE THE INTERVAL CONTAINING EIGENVALUES +* IL THROUGH IU. +* +* COMPUTE GERSHGORIN INTERVAL FOR ENTIRE (SPLIT) MATRIX +* AND USE IT AS THE INITIAL INTERVAL +* + GU = D( 1 ) + GL = D( 1 ) + TMP1 = ZERO +* + DO 20 J = 1, N - 1 + TMP2 = SQRT( WORK( J ) ) + GU = MAX( GU, D( J )+TMP1+TMP2 ) + GL = MIN( GL, D( J )-TMP1-TMP2 ) + TMP1 = TMP2 + 20 CONTINUE +* + GU = MAX( GU, D( N )+TMP1 ) + GL = MIN( GL, D( N )-TMP1 ) + TNORM = MAX( ABS( GL ), ABS( GU ) ) + GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN + GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN +* +* COMPUTE ITERATION PARAMETERS +* + ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) / + $ LOG( TWO ) ) + 2 + IF( ABSTOL.LE.ZERO ) THEN + ATOLI = ULP*TNORM + ELSE + ATOLI = ABSTOL + END IF +* + WORK( N+1 ) = GL + WORK( N+2 ) = GL + WORK( N+3 ) = GU + WORK( N+4 ) = GU + WORK( N+5 ) = GL + WORK( N+6 ) = GU + IWORK( 1 ) = -1 + IWORK( 2 ) = -1 + IWORK( 3 ) = N + 1 + IWORK( 4 ) = N + 1 + IWORK( 5 ) = IL - 1 + IWORK( 6 ) = IU +* + CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E, + $ WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT, + $ IWORK, W, IBLOCK, IINFO ) +* + IF( IWORK( 6 ).EQ.IU ) THEN + WL = WORK( N+1 ) + WLU = WORK( N+3 ) + NWL = IWORK( 1 ) + WU = WORK( N+4 ) + WUL = WORK( N+2 ) + NWU = IWORK( 4 ) + ELSE + WL = WORK( N+2 ) + WLU = WORK( N+4 ) + NWL = IWORK( 2 ) + WU = WORK( N+3 ) + WUL = WORK( N+1 ) + NWU = IWORK( 3 ) + END IF +* + IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN + INFO = 4 + RETURN + END IF + ELSE +* +* RANGE='A' OR 'V' -- SET ATOLI +* + TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ), + $ ABS( D( N ) )+ABS( E( N-1 ) ) ) +* + DO 30 J = 2, N - 1 + TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+ + $ ABS( E( J ) ) ) + 30 CONTINUE +* + IF( ABSTOL.LE.ZERO ) THEN + ATOLI = ULP*TNORM + ELSE + ATOLI = ABSTOL + END IF +* + IF( IRANGE.EQ.2 ) THEN + WL = VL + WU = VU + END IF + END IF +* +* FIND EIGENVALUES -- LOOP OVER BLOCKS AND RECOMPUTE NWL AND NWU. +* NWL ACCUMULATES THE NUMBER OF EIGENVALUES .LE. WL, +* NWU ACCUMULATES THE NUMBER OF EIGENVALUES .LE. WU +* + M = 0 + IEND = 0 + INFO = 0 + NWL = 0 + NWU = 0 +* + DO 70 JB = 1, NSPLIT + IOFF = IEND + IBEGIN = IOFF + 1 + IEND = ISPLIT( JB ) + IN = IEND - IOFF +* + IF( IN.EQ.1 ) THEN +* +* SPECIAL CASE -- IN=1 +* + IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN ) + $ NWL = NWL + 1 + IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN ) + $ NWU = NWU + 1 + IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE. + $ D( IBEGIN )-PIVMIN ) ) THEN + M = M + 1 + W( M ) = D( IBEGIN ) + IBLOCK( M ) = JB + END IF + ELSE +* +* GENERAL CASE -- IN > 1 +* +* COMPUTE GERSHGORIN INTERVAL +* AND USE IT AS THE INITIAL INTERVAL +* + GU = D( IBEGIN ) + GL = D( IBEGIN ) + TMP1 = ZERO +* + DO 40 J = IBEGIN, IEND - 1 + TMP2 = ABS( E( J ) ) + GU = MAX( GU, D( J )+TMP1+TMP2 ) + GL = MIN( GL, D( J )-TMP1-TMP2 ) + TMP1 = TMP2 + 40 CONTINUE +* + GU = MAX( GU, D( IEND )+TMP1 ) + GL = MIN( GL, D( IEND )-TMP1 ) + BNORM = MAX( ABS( GL ), ABS( GU ) ) + GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN + GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN +* + IF( IRANGE.GT.1 ) THEN + GL = MAX( GL, WL ) + GU = MIN( GU, WU ) + IF( GL.GE.GU ) + $ GO TO 70 + END IF +* +* SET UP INITIAL INTERVAL +* + WORK( N+1 ) = GL + WORK( N+IN+1 ) = GU + CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, + $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), + $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM, + $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) +* + NWL = NWL + IWORK( 1 ) + NWU = NWU + IWORK( IN+1 ) + IWOFF = M - IWORK( 1 ) +* +* COMPUTE EIGENVALUES +* + ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) / + $ LOG( TWO ) ) + 2 + CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN, + $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ), + $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT, + $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO ) +* +* COPY EIGENVALUES INTO W AND IBLOCK +* USE -JB FOR BLOCK NUMBER FOR UNCONVERGED EIGENVALUES. +* + DO 60 J = 1, IOUT + TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) ) +* +* FLAG NON-CONVERGENCE. +* + IF( J.GT.IOUT-IINFO ) THEN + NCNVRG = .TRUE. + IB = -JB + ELSE + IB = JB + END IF + DO 50 JE = IWORK( J ) + 1 + IWOFF, + $ IWORK( J+IN ) + IWOFF + W( JE ) = TMP1 + IBLOCK( JE ) = IB + 50 CONTINUE + 60 CONTINUE +* + M = M + IM + END IF + 70 CONTINUE +* +* IF RANGE='I', THEN (WL,WU) CONTAINS EIGENVALUES NWL+1,...,NWU +* IF NWL+1 < IL OR NWU > IU, DISCARD EXTRA EIGENVALUES. +* + IF( IRANGE.EQ.3 ) THEN + IM = 0 + IDISCL = IL - 1 - NWL + IDISCU = NWU - IU +* + IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN + DO 80 JE = 1, M + IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN + IDISCL = IDISCL - 1 + ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN + IDISCU = IDISCU - 1 + ELSE + IM = IM + 1 + W( IM ) = W( JE ) + IBLOCK( IM ) = IBLOCK( JE ) + END IF + 80 CONTINUE + M = IM + END IF + IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN +* +* CODE TO DEAL WITH EFFECTS OF BAD ARITHMETIC: +* SOME LOW EIGENVALUES TO BE DISCARDED ARE NOT IN (WL,WLU], +* OR HIGH EIGENVALUES TO BE DISCARDED ARE NOT IN (WUL,WU] +* SO JUST KILL OFF THE SMALLEST IDISCL/LARGEST IDISCU +* EIGENVALUES, BY SIMPLY FINDING THE SMALLEST/LARGEST +* EIGENVALUE(S). +* +* (IF N(W) IS MONOTONE NON-DECREASING, THIS SHOULD NEVER +* HAPPEN.) +* + IF( IDISCL.GT.0 ) THEN + WKILL = WU + DO 100 JDISC = 1, IDISCL + IW = 0 + DO 90 JE = 1, M + IF( IBLOCK( JE ).NE.0 .AND. + $ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN + IW = JE + WKILL = W( JE ) + END IF + 90 CONTINUE + IBLOCK( IW ) = 0 + 100 CONTINUE + END IF + IF( IDISCU.GT.0 ) THEN +* + WKILL = WL + DO 120 JDISC = 1, IDISCU + IW = 0 + DO 110 JE = 1, M + IF( IBLOCK( JE ).NE.0 .AND. + $ ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN + IW = JE + WKILL = W( JE ) + END IF + 110 CONTINUE + IBLOCK( IW ) = 0 + 120 CONTINUE + END IF + IM = 0 + DO 130 JE = 1, M + IF( IBLOCK( JE ).NE.0 ) THEN + IM = IM + 1 + W( IM ) = W( JE ) + IBLOCK( IM ) = IBLOCK( JE ) + END IF + 130 CONTINUE + M = IM + END IF + IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN + TOOFEW = .TRUE. + END IF + END IF +* +* IF ORDER='B', DO NOTHING -- THE EIGENVALUES ARE ALREADY SORTED +* BY BLOCK. +* IF ORDER='E' OR 'A', SORT THE EIGENVALUES FROM SMALLEST TO LARGEST +* + IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN + DO 150 JE = 1, M - 1 + IE = 0 + TMP1 = W( JE ) + DO 140 J = JE + 1, M + IF( W( J ).LT.TMP1 ) THEN + IE = J + TMP1 = W( J ) + END IF + 140 CONTINUE +* + IF( IE.NE.0 ) THEN + ITMP1 = IBLOCK( IE ) + W( IE ) = W( JE ) + IBLOCK( IE ) = IBLOCK( JE ) + W( JE ) = TMP1 + IBLOCK( JE ) = ITMP1 + END IF + 150 CONTINUE + END IF +* + INFO = 0 + IF( NCNVRG ) + $ INFO = INFO + 1 + IF( TOOFEW ) + $ INFO = INFO + 2 + RETURN +* +* END OF DSTEBZ +* + END +CUT HERE............ +CAT > DLAEBZ.F <<'CUT HERE............' + SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL, + $ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT, + $ NAB, WORK, IWORK, INFO ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* MARCH 31, 1993 +* +* .. SCALAR ARGUMENTS .. + INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX + DOUBLE PRECISION ABSTOL, PIVMIN, RELTOL +* .. +* .. ARRAY ARGUMENTS .. + INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * ) + DOUBLE PRECISION AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ), + $ WORK( * ) +* .. +* +* PURPOSE +* ======= +* +* DLAEBZ CONTAINS THE ITERATION LOOPS WHICH COMPUTE AND USE THE +* FUNCTION N(W), WHICH IS THE COUNT OF EIGENVALUES OF A SYMMETRIC +* TRIDIAGONAL MATRIX T LESS THAN OR EQUAL TO ITS ARGUMENT W. IT +* PERFORMS A CHOICE OF TWO TYPES OF LOOPS: +* +* IJOB=1, FOLLOWED BY +* IJOB=2: IT TAKES AS INPUT A LIST OF INTERVALS AND RETURNS A LIST OF +* SUFFICIENTLY SMALL INTERVALS WHOSE UNION CONTAINS THE SAME +* EIGENVALUES AS THE UNION OF THE ORIGINAL INTERVALS. +* THE INPUT INTERVALS ARE (AB(J,1),AB(J,2)], J=1,...,MINP. +* THE OUTPUT INTERVAL (AB(J,1),AB(J,2)] WILL CONTAIN +* EIGENVALUES NAB(J,1)+1,...,NAB(J,2), WHERE 1 <= J <= MOUT. +* +* IJOB=3: IT PERFORMS A BINARY SEARCH IN EACH INPUT INTERVAL +* (AB(J,1),AB(J,2)] FOR A POINT W(J) SUCH THAT +* N(W(J))=NVAL(J), AND USES C(J) AS THE STARTING POINT OF +* THE SEARCH. IF SUCH A W(J) IS FOUND, THEN ON OUTPUT +* AB(J,1)=AB(J,2)=W. IF NO SUCH W(J) IS FOUND, THEN ON OUTPUT +* (AB(J,1),AB(J,2)] WILL BE A SMALL INTERVAL CONTAINING THE +* POINT WHERE N(W) JUMPS THROUGH NVAL(J), UNLESS THAT POINT +* LIES OUTSIDE THE INITIAL INTERVAL. +* +* NOTE THAT THE INTERVALS ARE IN ALL CASES HALF-OPEN INTERVALS, +* I.E., OF THE FORM (A,B] , WHICH INCLUDES B BUT NOT A . +* +* SEE W. KAHAN "ACCURATE EIGENVALUES OF A SYMMETRIC TRIDIAGONAL +* MATRIX", REPORT CS41, COMPUTER SCIENCE DEPT., STANFORD +* UNIVERSITY, JULY 21, 1966 +* +* NOTE: THE ARGUMENTS ARE, IN GENERAL, *NOT* CHECKED FOR UNREASONABLE +* VALUES. +* +* ARGUMENTS +* ========= +* +* IJOB (INPUT) INTEGER +* SPECIFIES WHAT IS TO BE DONE: +* = 1: COMPUTE NAB FOR THE INITIAL INTERVALS. +* = 2: PERFORM BISECTION ITERATION TO FIND EIGENVALUES OF T. +* = 3: PERFORM BISECTION ITERATION TO INVERT N(W), I.E., +* TO FIND A POINT WHICH HAS A SPECIFIED NUMBER OF +* EIGENVALUES OF T TO ITS LEFT. +* OTHER VALUES WILL CAUSE DLAEBZ TO RETURN WITH INFO=-1. +* +* NITMAX (INPUT) INTEGER +* THE MAXIMUM NUMBER OF "LEVELS" OF BISECTION TO BE +* PERFORMED, I.E., AN INTERVAL OF WIDTH W WILL NOT BE MADE +* SMALLER THAN 2^(-NITMAX) * W. IF NOT ALL INTERVALS +* HAVE CONVERGED AFTER NITMAX ITERATIONS, THEN INFO IS SET +* TO THE NUMBER OF NON-CONVERGED INTERVALS. +* +* N (INPUT) INTEGER +* THE DIMENSION N OF THE TRIDIAGONAL MATRIX T. IT MUST BE AT +* LEAST 1. +* +* MMAX (INPUT) INTEGER +* THE MAXIMUM NUMBER OF INTERVALS. IF MORE THAN MMAX INTERVALS +* ARE GENERATED, THEN DLAEBZ WILL QUIT WITH INFO=MMAX+1. +* +* MINP (INPUT) INTEGER +* THE INITIAL NUMBER OF INTERVALS. IT MAY NOT BE GREATER THAN +* MMAX. +* +* NBMIN (INPUT) INTEGER +* THE SMALLEST NUMBER OF INTERVALS THAT SHOULD BE PROCESSED +* USING A VECTOR LOOP. IF ZERO, THEN ONLY THE SCALAR LOOP +* WILL BE USED. +* +* ABSTOL (INPUT) DOUBLE PRECISION +* THE MINIMUM (ABSOLUTE) WIDTH OF AN INTERVAL. WHEN AN +* INTERVAL IS NARROWER THAN ABSTOL, OR THAN RELTOL TIMES THE +* LARGER (IN MAGNITUDE) ENDPOINT, THEN IT IS CONSIDERED TO BE +* SUFFICIENTLY SMALL, I.E., CONVERGED. THIS MUST BE AT LEAST +* ZERO. +* +* RELTOL (INPUT) DOUBLE PRECISION +* THE MINIMUM RELATIVE WIDTH OF AN INTERVAL. WHEN AN INTERVAL +* IS NARROWER THAN ABSTOL, OR THAN RELTOL TIMES THE LARGER (IN +* MAGNITUDE) ENDPOINT, THEN IT IS CONSIDERED TO BE +* SUFFICIENTLY SMALL, I.E., CONVERGED. NOTE: THIS SHOULD +* ALWAYS BE AT LEAST RADIX*MACHINE EPSILON. +* +* PIVMIN (INPUT) DOUBLE PRECISION +* THE MINIMUM ABSOLUTE VALUE OF A "PIVOT" IN THE STURM +* SEQUENCE LOOP. THIS *MUST* BE AT LEAST MAX |E(J)**2| * +* SAFE_MIN AND AT LEAST SAFE_MIN, WHERE SAFE_MIN IS AT LEAST +* THE SMALLEST NUMBER THAT CAN DIVIDE ONE WITHOUT OVERFLOW. +* +* D (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T. TO AVOID +* UNDERFLOW, THE MATRIX SHOULD BE SCALED SO THAT ITS LARGEST +* ENTRY IS NO GREATER THAN OVERFLOW**(1/2) * UNDERFLOW**(1/4) +* IN ABSOLUTE VALUE. TO ASSURE THE MOST ACCURATE COMPUTATION +* OF SMALL EIGENVALUES, THE MATRIX SHOULD BE SCALED TO BE +* NOT MUCH SMALLER THAN THAT, EITHER. +* +* E (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* THE OFFDIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T IN +* POSITIONS 1 THROUGH N-1. E(N) IS ARBITRARY. +* TO AVOID UNDERFLOW, THE +* MATRIX SHOULD BE SCALED SO THAT ITS LARGEST ENTRY IS NO +* GREATER THAN OVERFLOW**(1/2) * UNDERFLOW**(1/4) IN ABSOLUTE +* VALUE. TO ASSURE THE MOST ACCURATE COMPUTATION OF SMALL +* EIGENVALUES, THE MATRIX SHOULD BE SCALED TO BE NOT MUCH +* SMALLER THAN THAT, EITHER. +* +* E2 (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* THE SQUARES OF THE OFFDIAGONAL ELEMENTS OF THE TRIDIAGONAL +* MATRIX T. E2(N) IS IGNORED. +* +* NVAL (INPUT/OUTPUT) INTEGER ARRAY, DIMENSION (MINP) +* IF IJOB=1 OR 2, NOT REFERENCED. +* IF IJOB=3, THE DESIRED VALUES OF N(W). THE ELEMENTS OF NVAL +* WILL BE REORDERED TO CORRESPOND WITH THE INTERVALS IN AB. +* THUS, NVAL(J) ON OUTPUT WILL NOT, IN GENERAL BE THE SAME AS +* NVAL(J) ON INPUT, BUT IT WILL CORRESPOND WITH THE INTERVAL +* (AB(J,1),AB(J,2)] ON OUTPUT. +* +* AB (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (MMAX,2) +* THE ENDPOINTS OF THE INTERVALS. AB(J,1) IS A(J), THE LEFT +* ENDPOINT OF THE J-TH INTERVAL, AND AB(J,2) IS B(J), THE +* RIGHT ENDPOINT OF THE J-TH INTERVAL. THE INPUT INTERVALS +* WILL, IN GENERAL, BE MODIFIED, SPLIT, AND REORDERED BY THE +* CALCULATION. +* +* C (INPUT/WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (MMAX) +* IF IJOB=1, IGNORED. +* IF IJOB=2, WORKSPACE. +* IF IJOB=3, THEN ON INPUT C(J) SHOULD BE INITIALIZED TO THE +* FIRST SEARCH POINT IN THE BINARY SEARCH. +* +* MOUT (OUTPUT) INTEGER +* IF IJOB=1, THE NUMBER OF EIGENVALUES IN THE INTERVALS. +* IF IJOB=2 OR 3, THE NUMBER OF INTERVALS OUTPUT. +* IF IJOB=3, MOUT WILL EQUAL MINP. +* +* NAB (INPUT/OUTPUT) INTEGER ARRAY, DIMENSION (MMAX,2) +* IF IJOB=1, THEN ON OUTPUT NAB(I,J) WILL BE SET TO N(AB(I,J)). +* IF IJOB=2, THEN ON INPUT, NAB(I,J) SHOULD BE SET. IT MUST +* SATISFY THE CONDITION: +* N(AB(I,1)) <= NAB(I,1) <= NAB(I,2) <= N(AB(I,2)), +* WHICH MEANS THAT IN INTERVAL I ONLY EIGENVALUES +* NAB(I,1)+1,...,NAB(I,2) WILL BE CONSIDERED. USUALLY, +* NAB(I,J)=N(AB(I,J)), FROM A PREVIOUS CALL TO DLAEBZ WITH +* IJOB=1. +* ON OUTPUT, NAB(I,J) WILL CONTAIN +* MAX(NA(K),MIN(NB(K),N(AB(I,J)))), WHERE K IS THE INDEX OF +* THE INPUT INTERVAL THAT THE OUTPUT INTERVAL +* (AB(J,1),AB(J,2)] CAME FROM, AND NA(K) AND NB(K) ARE THE +* THE INPUT VALUES OF NAB(K,1) AND NAB(K,2). +* IF IJOB=3, THEN ON OUTPUT, NAB(I,J) CONTAINS N(AB(I,J)), +* UNLESS N(W) > NVAL(I) FOR ALL SEARCH POINTS W , IN WHICH +* CASE NAB(I,1) WILL NOT BE MODIFIED, I.E., THE OUTPUT +* VALUE WILL BE THE SAME AS THE INPUT VALUE (MODULO +* REORDERINGS -- SEE NVAL AND AB), OR UNLESS N(W) < NVAL(I) +* FOR ALL SEARCH POINTS W , IN WHICH CASE NAB(I,2) WILL +* NOT BE MODIFIED. NORMALLY, NAB SHOULD BE SET TO SOME +* DISTINCTIVE VALUE(S) BEFORE DLAEBZ IS CALLED. +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (MMAX) +* WORKSPACE. +* +* IWORK (WORKSPACE) INTEGER ARRAY, DIMENSION (MMAX) +* WORKSPACE. +* +* INFO (OUTPUT) INTEGER +* = 0: ALL INTERVALS CONVERGED. +* = 1--MMAX: THE LAST INFO INTERVALS DID NOT CONVERGE. +* = MMAX+1: MORE THAN MMAX INTERVALS WERE GENERATED. +* +* FURTHER DETAILS +* =============== +* +* THIS ROUTINE IS INTENDED TO BE CALLED ONLY BY OTHER LAPACK +* ROUTINES, THUS THE INTERFACE IS LESS USER-FRIENDLY. IT IS INTENDED +* FOR TWO PURPOSES: +* +* (A) FINDING EIGENVALUES. IN THIS CASE, DLAEBZ SHOULD HAVE ONE OR +* MORE INITIAL INTERVALS SET UP IN AB, AND DLAEBZ SHOULD BE CALLED +* WITH IJOB=1. THIS SETS UP NAB, AND ALSO COUNTS THE EIGENVALUES. +* INTERVALS WITH NO EIGENVALUES WOULD USUALLY BE THROWN OUT AT +* THIS POINT. ALSO, IF NOT ALL THE EIGENVALUES IN AN INTERVAL I +* ARE DESIRED, NAB(I,1) CAN BE INCREASED OR NAB(I,2) DECREASED. +* FOR EXAMPLE, SET NAB(I,1)=NAB(I,2)-1 TO GET THE LARGEST +* EIGENVALUE. DLAEBZ IS THEN CALLED WITH IJOB=2 AND MMAX +* NO SMALLER THAN THE VALUE OF MOUT RETURNED BY THE CALL WITH +* IJOB=1. AFTER THIS (IJOB=2) CALL, EIGENVALUES NAB(I,1)+1 +* THROUGH NAB(I,2) ARE APPROXIMATELY AB(I,1) (OR AB(I,2)) TO THE +* TOLERANCE SPECIFIED BY ABSTOL AND RELTOL. +* +* (B) FINDING AN INTERVAL (A',B'] CONTAINING EIGENVALUES W(F),...,W(L). +* IN THIS CASE, START WITH A GERSHGORIN INTERVAL (A,B). SET UP +* AB TO CONTAIN 2 SEARCH INTERVALS, BOTH INITIALLY (A,B). ONE +* NVAL ENTRY SHOULD CONTAIN F-1 AND THE OTHER SHOULD CONTAIN L +* , WHILE C SHOULD CONTAIN A AND B, RESP. NAB(I,1) SHOULD BE -1 +* AND NAB(I,2) SHOULD BE N+1, TO FLAG AN ERROR IF THE DESIRED +* INTERVAL DOES NOT LIE IN (A,B). DLAEBZ IS THEN CALLED WITH +* IJOB=3. ON EXIT, IF W(F-1) < W(F), THEN ONE OF THE INTERVALS -- +* J -- WILL HAVE AB(J,1)=AB(J,2) AND NAB(J,1)=NAB(J,2)=F-1, WHILE +* IF, TO THE SPECIFIED TOLERANCE, W(F-K)=...=W(F+R), K > 0 AND R +* >= 0, THEN THE INTERVAL WILL HAVE N(AB(J,1))=NAB(J,1)=F-K AND +* N(AB(J,2))=NAB(J,2)=F+R. THE CASES W(L) < W(L+1) AND +* W(L-R)=...=W(L+K) ARE HANDLED SIMILARLY. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO, TWO, HALF + PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0, + $ HALF = 1.0D0 / TWO ) +* .. +* .. LOCAL SCALARS .. + INTEGER ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL, + $ KLNEW + DOUBLE PRECISION TMP1, TMP2 +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS, MAX, MIN +* .. +* .. EXECUTABLE STATEMENTS .. +* +* CHECK FOR ERRORS +* + INFO = 0 + IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN + INFO = -1 + RETURN + END IF +* +* INITIALIZE NAB +* + IF( IJOB.EQ.1 ) THEN +* +* COMPUTE THE NUMBER OF EIGENVALUES IN THE INITIAL INTERVALS. +* + MOUT = 0 + DO 30 JI = 1, MINP + DO 20 JP = 1, 2 + TMP1 = D( 1 ) - AB( JI, JP ) + IF( ABS( TMP1 ).LT.PIVMIN ) + $ TMP1 = -PIVMIN + NAB( JI, JP ) = 0 + IF( TMP1.LE.ZERO ) + $ NAB( JI, JP ) = 1 +* + DO 10 J = 2, N + TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP ) + IF( ABS( TMP1 ).LT.PIVMIN ) + $ TMP1 = -PIVMIN + IF( TMP1.LE.ZERO ) + $ NAB( JI, JP ) = NAB( JI, JP ) + 1 + 10 CONTINUE + 20 CONTINUE + MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 ) + 30 CONTINUE + RETURN + END IF +* +* INITIALIZE FOR LOOP +* +* KF AND KL HAVE THE FOLLOWING MEANING: +* INTERVALS 1,...,KF-1 HAVE CONVERGED. +* INTERVALS KF,...,KL STILL NEED TO BE REFINED. +* + KF = 1 + KL = MINP +* +* IF IJOB=2, INITIALIZE C. +* IF IJOB=3, USE THE USER-SUPPLIED STARTING POINT. +* + IF( IJOB.EQ.2 ) THEN + DO 40 JI = 1, MINP + C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) ) + 40 CONTINUE + END IF +* +* ITERATION LOOP +* + DO 130 JIT = 1, NITMAX +* +* LOOP OVER INTERVALS +* + IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN +* +* BEGIN OF PARALLEL VERSION OF THE LOOP +* + DO 60 JI = KF, KL +* +* COMPUTE N(C), THE NUMBER OF EIGENVALUES LESS THAN C +* + WORK( JI ) = D( 1 ) - C( JI ) + IWORK( JI ) = 0 + IF( WORK( JI ).LE.PIVMIN ) THEN + IWORK( JI ) = 1 + WORK( JI ) = MIN( WORK( JI ), -PIVMIN ) + END IF +* + DO 50 J = 2, N + WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI ) + IF( WORK( JI ).LE.PIVMIN ) THEN + IWORK( JI ) = IWORK( JI ) + 1 + WORK( JI ) = MIN( WORK( JI ), -PIVMIN ) + END IF + 50 CONTINUE + 60 CONTINUE +* + IF( IJOB.LE.2 ) THEN +* +* IJOB=2: CHOOSE ALL INTERVALS CONTAINING EIGENVALUES. +* + KLNEW = KL + DO 70 JI = KF, KL +* +* INSURE THAT N(W) IS MONOTONE +* + IWORK( JI ) = MIN( NAB( JI, 2 ), + $ MAX( NAB( JI, 1 ), IWORK( JI ) ) ) +* +* UPDATE THE QUEUE -- ADD INTERVALS IF BOTH HALVES +* CONTAIN EIGENVALUES. +* + IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN +* +* NO EIGENVALUE IN THE UPPER INTERVAL: +* JUST USE THE LOWER INTERVAL. +* + AB( JI, 2 ) = C( JI ) +* + ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN +* +* NO EIGENVALUE IN THE LOWER INTERVAL: +* JUST USE THE UPPER INTERVAL. +* + AB( JI, 1 ) = C( JI ) + ELSE + KLNEW = KLNEW + 1 + IF( KLNEW.LE.MMAX ) THEN +* +* EIGENVALUE IN BOTH INTERVALS -- ADD UPPER TO +* QUEUE. +* + AB( KLNEW, 2 ) = AB( JI, 2 ) + NAB( KLNEW, 2 ) = NAB( JI, 2 ) + AB( KLNEW, 1 ) = C( JI ) + NAB( KLNEW, 1 ) = IWORK( JI ) + AB( JI, 2 ) = C( JI ) + NAB( JI, 2 ) = IWORK( JI ) + ELSE + INFO = MMAX + 1 + END IF + END IF + 70 CONTINUE + IF( INFO.NE.0 ) + $ RETURN + KL = KLNEW + ELSE +* +* IJOB=3: BINARY SEARCH. KEEP ONLY THE INTERVAL CONTAINING +* W S.T. N(W) = NVAL +* + DO 80 JI = KF, KL + IF( IWORK( JI ).LE.NVAL( JI ) ) THEN + AB( JI, 1 ) = C( JI ) + NAB( JI, 1 ) = IWORK( JI ) + END IF + IF( IWORK( JI ).GE.NVAL( JI ) ) THEN + AB( JI, 2 ) = C( JI ) + NAB( JI, 2 ) = IWORK( JI ) + END IF + 80 CONTINUE + END IF +* + ELSE +* +* END OF PARALLEL VERSION OF THE LOOP +* +* BEGIN OF SERIAL VERSION OF THE LOOP +* + KLNEW = KL + DO 100 JI = KF, KL +* +* COMPUTE N(W), THE NUMBER OF EIGENVALUES LESS THAN W +* + TMP1 = C( JI ) + TMP2 = D( 1 ) - TMP1 + ITMP1 = 0 + IF( TMP2.LE.PIVMIN ) THEN + ITMP1 = 1 + TMP2 = MIN( TMP2, -PIVMIN ) + END IF +* +* A SERIES OF COMPILER DIRECTIVES TO DEFEAT VECTORIZATION +* FOR THE NEXT LOOP +* +*$PL$ CMCHAR=' ' +CDIR$ NEXTSCALAR +C$DIR SCALAR +CDIR$ NEXT SCALAR +CVD$L NOVECTOR +CDEC$ NOVECTOR +CVD$ NOVECTOR +*VDIR NOVECTOR +*VOCL LOOP,SCALAR +CIBM PREFER SCALAR +*$PL$ CMCHAR='*' +* + DO 90 J = 2, N + TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1 + IF( TMP2.LE.PIVMIN ) THEN + ITMP1 = ITMP1 + 1 + TMP2 = MIN( TMP2, -PIVMIN ) + END IF + 90 CONTINUE +* + IF( IJOB.LE.2 ) THEN +* +* IJOB=2: CHOOSE ALL INTERVALS CONTAINING EIGENVALUES. +* +* INSURE THAT N(W) IS MONOTONE +* + ITMP1 = MIN( NAB( JI, 2 ), + $ MAX( NAB( JI, 1 ), ITMP1 ) ) +* +* UPDATE THE QUEUE -- ADD INTERVALS IF BOTH HALVES +* CONTAIN EIGENVALUES. +* + IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN +* +* NO EIGENVALUE IN THE UPPER INTERVAL: +* JUST USE THE LOWER INTERVAL. +* + AB( JI, 2 ) = TMP1 +* + ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN +* +* NO EIGENVALUE IN THE LOWER INTERVAL: +* JUST USE THE UPPER INTERVAL. +* + AB( JI, 1 ) = TMP1 + ELSE IF( KLNEW.LT.MMAX ) THEN +* +* EIGENVALUE IN BOTH INTERVALS -- ADD UPPER TO QUEUE. +* + KLNEW = KLNEW + 1 + AB( KLNEW, 2 ) = AB( JI, 2 ) + NAB( KLNEW, 2 ) = NAB( JI, 2 ) + AB( KLNEW, 1 ) = TMP1 + NAB( KLNEW, 1 ) = ITMP1 + AB( JI, 2 ) = TMP1 + NAB( JI, 2 ) = ITMP1 + ELSE + INFO = MMAX + 1 + RETURN + END IF + ELSE +* +* IJOB=3: BINARY SEARCH. KEEP ONLY THE INTERVAL +* CONTAINING W S.T. N(W) = NVAL +* + IF( ITMP1.LE.NVAL( JI ) ) THEN + AB( JI, 1 ) = TMP1 + NAB( JI, 1 ) = ITMP1 + END IF + IF( ITMP1.GE.NVAL( JI ) ) THEN + AB( JI, 2 ) = TMP1 + NAB( JI, 2 ) = ITMP1 + END IF + END IF + 100 CONTINUE + KL = KLNEW +* +* END OF SERIAL VERSION OF THE LOOP +* + END IF +* +* CHECK FOR CONVERGENCE +* + KFNEW = KF + DO 110 JI = KF, KL + TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) ) + TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) ) + IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR. + $ NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN +* +* CONVERGED -- SWAP WITH POSITION KFNEW, +* THEN INCREMENT KFNEW +* + IF( JI.GT.KFNEW ) THEN + TMP1 = AB( JI, 1 ) + TMP2 = AB( JI, 2 ) + ITMP1 = NAB( JI, 1 ) + ITMP2 = NAB( JI, 2 ) + AB( JI, 1 ) = AB( KFNEW, 1 ) + AB( JI, 2 ) = AB( KFNEW, 2 ) + NAB( JI, 1 ) = NAB( KFNEW, 1 ) + NAB( JI, 2 ) = NAB( KFNEW, 2 ) + AB( KFNEW, 1 ) = TMP1 + AB( KFNEW, 2 ) = TMP2 + NAB( KFNEW, 1 ) = ITMP1 + NAB( KFNEW, 2 ) = ITMP2 + IF( IJOB.EQ.3 ) THEN + ITMP1 = NVAL( JI ) + NVAL( JI ) = NVAL( KFNEW ) + NVAL( KFNEW ) = ITMP1 + END IF + END IF + KFNEW = KFNEW + 1 + END IF + 110 CONTINUE + KF = KFNEW +* +* CHOOSE MIDPOINTS +* + DO 120 JI = KF, KL + C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) ) + 120 CONTINUE +* +* IF NO MORE INTERVALS TO REFINE, QUIT. +* + IF( KF.GT.KL ) + $ GO TO 140 + 130 CONTINUE +* +* CONVERGED +* + 140 CONTINUE + INFO = MAX( KL+1-KF, 0 ) + MOUT = KL +* + RETURN +* +* END OF DLAEBZ +* + END +CUT HERE............ +CAT > DSTEQR.F <<'CUT HERE............' + SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* MARCH 31, 1993 +* +* .. SCALAR ARGUMENTS .. + CHARACTER COMPZ + INTEGER INFO, LDZ, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * ) +* .. +* +* PURPOSE +* ======= +* +* DSTEQR COMPUTES ALL EIGENVALUES AND, OPTIONALLY, EIGENVECTORS OF A +* SYMMETRIC TRIDIAGONAL MATRIX USING THE IMPLICIT QL OR QR METHOD. +* THE EIGENVECTORS OF A FULL OR BAND SYMMETRIC MATRIX CAN ALSO BE FOUND +* IF DSYTRD OR DSPTRD OR DSBTRD HAS BEEN USED TO REDUCE THIS MATRIX TO +* TRIDIAGONAL FORM. +* +* ARGUMENTS +* ========= +* +* COMPZ (INPUT) CHARACTER*1 +* = 'N': COMPUTE EIGENVALUES ONLY. +* = 'V': COMPUTE EIGENVALUES AND EIGENVECTORS OF THE ORIGINAL +* SYMMETRIC MATRIX. ON ENTRY, Z MUST CONTAIN THE +* ORTHOGONAL MATRIX USED TO REDUCE THE ORIGINAL MATRIX +* TO TRIDIAGONAL FORM. +* = 'I': COMPUTE EIGENVALUES AND EIGENVECTORS OF THE +* TRIDIAGONAL MATRIX. Z IS INITIALIZED TO THE IDENTITY +* MATRIX. +* +* N (INPUT) INTEGER +* THE ORDER OF THE MATRIX. N >= 0. +* +* D (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* ON ENTRY, THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. +* ON EXIT, IF INFO = 0, THE EIGENVALUES IN ASCENDING ORDER. +* +* E (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) +* ON ENTRY, THE (N-1) SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL +* MATRIX. +* ON EXIT, E HAS BEEN DESTROYED. +* +* Z (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDZ, N) +* ON ENTRY, IF COMPZ = 'V', THEN Z CONTAINS THE ORTHOGONAL +* MATRIX USED IN THE REDUCTION TO TRIDIAGONAL FORM. +* ON EXIT, IF COMPZ = 'V', Z CONTAINS THE ORTHONORMAL +* EIGENVECTORS OF THE ORIGINAL SYMMETRIC MATRIX, AND IF +* COMPZ = 'I', Z CONTAINS THE ORTHONORMAL EIGENVECTORS OF +* THE SYMMETRIC TRIDIAGONAL MATRIX. IF AN ERROR EXIT IS +* MADE, Z CONTAINS THE EIGENVECTORS ASSOCIATED WITH THE +* STORED EIGENVALUES. +* IF COMPZ = 'N', THEN Z IS NOT REFERENCED. +* +* LDZ (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY Z. LDZ >= 1, AND IF +* EIGENVECTORS ARE DESIRED, THEN LDZ >= MAX(1,N). +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (MAX(1,2*N-2)) +* IF COMPZ = 'N', THEN WORK IS NOT REFERENCED. +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE +* > 0: THE ALGORITHM HAS FAILED TO FIND ALL THE EIGENVALUES IN +* A TOTAL OF 30*N ITERATIONS; IF INFO = I, THEN I +* ELEMENTS OF E HAVE NOT CONVERGED TO ZERO; ON EXIT, D +* AND E CONTAIN THE ELEMENTS OF A SYMMETRIC TRIDIAGONAL +* MATRIX WHICH IS ORTHOGONALLY SIMILAR TO THE ORIGINAL +* MATRIX. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) + INTEGER MAXIT + PARAMETER ( MAXIT = 30 ) +* .. +* .. LOCAL SCALARS .. + INTEGER I, ICOMPZ, II, J, JTOT, K, L, L1, LEND, LENDM1, + $ LENDP1, LM1, M, MM, MM1, NM1, NMAXIT + DOUBLE PRECISION B, C, EPS, F, G, P, R, RT1, RT2, S, TST +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL LSAME, DLAMCH, DLAPY2 +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLAE2, DLAEV2, DLARTG, DLASR, DLAZRO, DSWAP, + $ XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS, MAX, SIGN +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 +* + IF( LSAME( COMPZ, 'N' ) ) THEN + ICOMPZ = 0 + ELSE IF( LSAME( COMPZ, 'V' ) ) THEN + ICOMPZ = 1 + ELSE IF( LSAME( COMPZ, 'I' ) ) THEN + ICOMPZ = 2 + ELSE + ICOMPZ = -1 + END IF + IF( ICOMPZ.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, + $ N ) ) ) THEN + INFO = -6 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSTEQR', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( N.EQ.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + IF( ICOMPZ.GT.0 ) + $ Z( 1, 1 ) = ONE + RETURN + END IF +* +* DETERMINE THE UNIT ROUNDOFF FOR THIS ENVIRONMENT. +* + EPS = DLAMCH( 'E' ) +* +* COMPUTE THE EIGENVALUES AND EIGENVECTORS OF THE TRIDIAGONAL +* MATRIX. +* + IF( ICOMPZ.EQ.2 ) + $ CALL DLAZRO( N, N, ZERO, ONE, Z, LDZ ) +* + NMAXIT = N*MAXIT + JTOT = 0 +* +* DETERMINE WHERE THE MATRIX SPLITS AND CHOOSE QL OR QR ITERATION +* FOR EACH BLOCK, ACCORDING TO WHETHER TOP OR BOTTOM DIAGONAL +* ELEMENT IS SMALLER. +* + L1 = 1 + NM1 = N - 1 +* + 10 CONTINUE + IF( L1.GT.N ) + $ GO TO 160 + IF( L1.GT.1 ) + $ E( L1-1 ) = ZERO + IF( L1.LE.NM1 ) THEN + DO 20 M = L1, NM1 + TST = ABS( E( M ) ) + IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) ) + $ GO TO 30 + 20 CONTINUE + END IF + M = N +* + 30 CONTINUE + L = L1 + LEND = M + IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN + L = LEND + LEND = L1 + END IF + L1 = M + 1 +* + IF( LEND.GE.L ) THEN +* +* QL ITERATION +* +* LOOK FOR SMALL SUBDIAGONAL ELEMENT. +* + 40 CONTINUE + IF( L.NE.LEND ) THEN + LENDM1 = LEND - 1 + DO 50 M = L, LENDM1 + TST = ABS( E( M ) ) + IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) ) + $ GO TO 60 + 50 CONTINUE + END IF +* + M = LEND +* + 60 CONTINUE + IF( M.LT.LEND ) + $ E( M ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 80 +* +* IF REMAINING MATRIX IS 2-BY-2, USE DLAE2 OR DLAEV2 +* TO COMPUTE ITS EIGENSYSTEM. +* + IF( M.EQ.L+1 ) THEN + IF( ICOMPZ.GT.0 ) THEN + CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S ) + WORK( L ) = C + WORK( N-1+L ) = S + CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ), + $ WORK( N-1+L ), Z( 1, L ), LDZ ) + ELSE + CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 ) + END IF + D( L ) = RT1 + D( L+1 ) = RT2 + E( L ) = ZERO + L = L + 2 + IF( L.LE.LEND ) + $ GO TO 40 + GO TO 10 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 140 + JTOT = JTOT + 1 +* +* FORM SHIFT. +* + G = ( D( L+1 )-P ) / ( TWO*E( L ) ) + R = DLAPY2( G, ONE ) + G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) ) +* + S = ONE + C = ONE + P = ZERO +* +* INNER LOOP +* + MM1 = M - 1 + DO 70 I = MM1, L, -1 + F = S*E( I ) + B = C*E( I ) + CALL DLARTG( G, F, C, S, R ) + IF( I.NE.M-1 ) + $ E( I+1 ) = R + G = D( I+1 ) - P + R = ( D( I )-G )*S + TWO*C*B + P = S*R + D( I+1 ) = G + P + G = C*R - B +* +* IF EIGENVECTORS ARE DESIRED, THEN SAVE ROTATIONS. +* + IF( ICOMPZ.GT.0 ) THEN + WORK( I ) = C + WORK( N-1+I ) = -S + END IF +* + 70 CONTINUE +* +* IF EIGENVECTORS ARE DESIRED, THEN APPLY SAVED ROTATIONS. +* + IF( ICOMPZ.GT.0 ) THEN + MM = M - L + 1 + CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ), + $ Z( 1, L ), LDZ ) + END IF +* + D( L ) = D( L ) - P + E( L ) = G + GO TO 40 +* +* EIGENVALUE FOUND. +* + 80 CONTINUE + D( L ) = P +* + L = L + 1 + IF( L.LE.LEND ) + $ GO TO 40 + GO TO 10 +* + ELSE +* +* QR ITERATION +* +* LOOK FOR SMALL SUPERDIAGONAL ELEMENT. +* + 90 CONTINUE + IF( L.NE.LEND ) THEN + LENDP1 = LEND + 1 + DO 100 M = L, LENDP1, -1 + TST = ABS( E( M-1 ) ) + IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M-1 ) ) ) ) + $ GO TO 110 + 100 CONTINUE + END IF +* + M = LEND +* + 110 CONTINUE + IF( M.GT.LEND ) + $ E( M-1 ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 130 +* +* IF REMAINING MATRIX IS 2-BY-2, USE DLAE2 OR DLAEV2 +* TO COMPUTE ITS EIGENSYSTEM. +* + IF( M.EQ.L-1 ) THEN + IF( ICOMPZ.GT.0 ) THEN + CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S ) + WORK( M ) = C + WORK( N-1+M ) = S + CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ), + $ WORK( N-1+M ), Z( 1, L-1 ), LDZ ) + ELSE + CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 ) + END IF + D( L-1 ) = RT1 + D( L ) = RT2 + E( L-1 ) = ZERO + L = L - 2 + IF( L.GE.LEND ) + $ GO TO 90 + GO TO 10 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 140 + JTOT = JTOT + 1 +* +* FORM SHIFT. +* + G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) ) + R = DLAPY2( G, ONE ) + G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) ) +* + S = ONE + C = ONE + P = ZERO +* +* INNER LOOP +* + LM1 = L - 1 + DO 120 I = M, LM1 + F = S*E( I ) + B = C*E( I ) + CALL DLARTG( G, F, C, S, R ) + IF( I.NE.M ) + $ E( I-1 ) = R + G = D( I ) - P + R = ( D( I+1 )-G )*S + TWO*C*B + P = S*R + D( I ) = G + P + G = C*R - B +* +* IF EIGENVECTORS ARE DESIRED, THEN SAVE ROTATIONS. +* + IF( ICOMPZ.GT.0 ) THEN + WORK( I ) = C + WORK( N-1+I ) = S + END IF +* + 120 CONTINUE +* +* IF EIGENVECTORS ARE DESIRED, THEN APPLY SAVED ROTATIONS. +* + IF( ICOMPZ.GT.0 ) THEN + MM = L - M + 1 + CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ), + $ Z( 1, M ), LDZ ) + END IF +* + D( L ) = D( L ) - P + E( LM1 ) = G + GO TO 90 +* +* EIGENVALUE FOUND. +* + 130 CONTINUE + D( L ) = P +* + L = L - 1 + IF( L.GE.LEND ) + $ GO TO 90 + GO TO 10 +* + END IF +* +* SET ERROR -- NO CONVERGENCE TO AN EIGENVALUE AFTER A TOTAL +* OF N*MAXIT ITERATIONS. +* + 140 CONTINUE + DO 150 I = 1, N - 1 + IF( E( I ).NE.ZERO ) + $ INFO = INFO + 1 + 150 CONTINUE + RETURN +* +* ORDER EIGENVALUES AND EIGENVECTORS. +* + 160 CONTINUE + DO 180 II = 2, N + I = II - 1 + K = I + P = D( I ) + DO 170 J = II, N + IF( D( J ).LT.P ) THEN + K = J + P = D( J ) + END IF + 170 CONTINUE + IF( K.NE.I ) THEN + D( K ) = D( I ) + D( I ) = P + IF( ICOMPZ.GT.0 ) + $ CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 ) + END IF + 180 CONTINUE +* + RETURN +* +* END OF DSTEQR +* + END +CUT HERE............ +CAT > DLARTG.F <<'CUT HERE............' + SUBROUTINE DLARTG( F, G, CS, SN, R ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + DOUBLE PRECISION CS, F, G, R, SN +* .. +* +* PURPOSE +* ======= +* +* DLARTG GENERATE A PLANE ROTATION SO THAT +* +* [ CS SN ] . [ F ] = [ R ] WHERE CS**2 + SN**2 = 1. +* [ -SN CS ] [ G ] [ 0 ] +* +* THIS IS A FASTER VERSION OF THE BLAS1 ROUTINE DROTG, EXCEPT FOR +* THE FOLLOWING DIFFERENCES: +* F AND G ARE UNCHANGED ON RETURN. +* IF G=0, THEN CS=1 AND SN=0. +* IF F=0 AND (G .NE. 0), THEN CS=0 AND SN=1 WITHOUT DOING ANY +* FLOATING POINT OPERATIONS (SAVES WORK IN DBDSQR WHEN +* THERE ARE ZEROS ON THE DIAGONAL). +* +* ARGUMENTS +* ========= +* +* F (INPUT) DOUBLE PRECISION +* THE FIRST COMPONENT OF VECTOR TO BE ROTATED. +* +* G (INPUT) DOUBLE PRECISION +* THE SECOND COMPONENT OF VECTOR TO BE ROTATED. +* +* CS (OUTPUT) DOUBLE PRECISION +* THE COSINE OF THE ROTATION. +* +* SN (OUTPUT) DOUBLE PRECISION +* THE SINE OF THE ROTATION. +* +* R (OUTPUT) DOUBLE PRECISION +* THE NONZERO COMPONENT OF THE ROTATED VECTOR. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. LOCAL SCALARS .. + DOUBLE PRECISION T, TT +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS, SQRT +* .. +* .. EXECUTABLE STATEMENTS .. +* + IF( G.EQ.ZERO ) THEN + CS = ONE + SN = ZERO + R = F + ELSE IF( F.EQ.ZERO ) THEN + CS = ZERO + SN = ONE + R = G + ELSE + IF( ABS( F ).GT.ABS( G ) ) THEN + T = G / F + TT = SQRT( ONE+T*T ) + CS = ONE / TT + SN = T*CS + R = F*TT + ELSE + T = F / G + TT = SQRT( ONE+T*T ) + SN = ONE / TT + CS = T*SN + R = G*TT + END IF + END IF + RETURN +* +* END OF DLARTG +* + END +CUT HERE............ +CAT > DLASR.F <<'CUT HERE............' + SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + CHARACTER DIRECT, PIVOT, SIDE + INTEGER LDA, M, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) +* .. +* +* PURPOSE +* ======= +* +* DLASR PERFORMS THE TRANSFORMATION +* +* A := P*A, WHEN SIDE = 'L' OR 'L' ( LEFT-HAND SIDE ) +* +* A := A*P', WHEN SIDE = 'R' OR 'R' ( RIGHT-HAND SIDE ) +* +* WHERE A IS AN M BY N REAL MATRIX AND P IS AN ORTHOGONAL MATRIX, +* CONSISTING OF A SEQUENCE OF PLANE ROTATIONS DETERMINED BY THE +* PARAMETERS PIVOT AND DIRECT AS FOLLOWS ( Z = M WHEN SIDE = 'L' OR 'L' +* AND Z = N WHEN SIDE = 'R' OR 'R' ): +* +* WHEN DIRECT = 'F' OR 'F' ( FORWARD SEQUENCE ) THEN +* +* P = P( Z - 1 )*...*P( 2 )*P( 1 ), +* +* AND WHEN DIRECT = 'B' OR 'B' ( BACKWARD SEQUENCE ) THEN +* +* P = P( 1 )*P( 2 )*...*P( Z - 1 ), +* +* WHERE P( K ) IS A PLANE ROTATION MATRIX FOR THE FOLLOWING PLANES: +* +* WHEN PIVOT = 'V' OR 'V' ( VARIABLE PIVOT ), +* THE PLANE ( K, K + 1 ) +* +* WHEN PIVOT = 'T' OR 'T' ( TOP PIVOT ), +* THE PLANE ( 1, K + 1 ) +* +* WHEN PIVOT = 'B' OR 'B' ( BOTTOM PIVOT ), +* THE PLANE ( K, Z ) +* +* C( K ) AND S( K ) MUST CONTAIN THE COSINE AND SINE THAT DEFINE THE +* MATRIX P( K ). THE TWO BY TWO PLANE ROTATION PART OF THE MATRIX +* P( K ), R( K ), IS ASSUMED TO BE OF THE FORM +* +* R( K ) = ( C( K ) S( K ) ). +* ( -S( K ) C( K ) ) +* +* THIS VERSION VECTORISES ACROSS ROWS OF THE ARRAY A WHEN SIDE = 'L'. +* +* ARGUMENTS +* ========= +* +* SIDE (INPUT) CHARACTER*1 +* SPECIFIES WHETHER THE PLANE ROTATION MATRIX P IS APPLIED TO +* A ON THE LEFT OR THE RIGHT. +* = 'L': LEFT, COMPUTE A := P*A +* = 'R': RIGHT, COMPUTE A:= A*P' +* +* DIRECT (INPUT) CHARACTER*1 +* SPECIFIES WHETHER P IS A FORWARD OR BACKWARD SEQUENCE OF +* PLANE ROTATIONS. +* = 'F': FORWARD, P = P( Z - 1 )*...*P( 2 )*P( 1 ) +* = 'B': BACKWARD, P = P( 1 )*P( 2 )*...*P( Z - 1 ) +* +* PIVOT (INPUT) CHARACTER*1 +* SPECIFIES THE PLANE FOR WHICH P(K) IS A PLANE ROTATION +* MATRIX. +* = 'V': VARIABLE PIVOT, THE PLANE (K,K+1) +* = 'T': TOP PIVOT, THE PLANE (1,K+1) +* = 'B': BOTTOM PIVOT, THE PLANE (K,Z) +* +* M (INPUT) INTEGER +* THE NUMBER OF ROWS OF THE MATRIX A. IF M <= 1, AN IMMEDIATE +* RETURN IS EFFECTED. +* +* N (INPUT) INTEGER +* THE NUMBER OF COLUMNS OF THE MATRIX A. IF N <= 1, AN +* IMMEDIATE RETURN IS EFFECTED. +* +* C, S (INPUT) DOUBLE PRECISION ARRAYS, DIMENSION +* (M-1) IF SIDE = 'L' +* (N-1) IF SIDE = 'R' +* C(K) AND S(K) CONTAIN THE COSINE AND SINE THAT DEFINE THE +* MATRIX P(K). THE TWO BY TWO PLANE ROTATION PART OF THE +* MATRIX P(K), R(K), IS ASSUMED TO BE OF THE FORM +* R( K ) = ( C( K ) S( K ) ). +* ( -S( K ) C( K ) ) +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* THE M BY N MATRIX A. ON EXIT, A IS OVERWRITTEN BY P*A IF +* SIDE = 'R' OR BY A*P' IF SIDE = 'L'. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,M). +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER I, INFO, J + DOUBLE PRECISION CTEMP, STEMP, TEMP +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS +* + INFO = 0 + IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN + INFO = 1 + ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, + $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN + INFO = 2 + ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) + $ THEN + INFO = 3 + ELSE IF( M.LT.0 ) THEN + INFO = 4 + ELSE IF( N.LT.0 ) THEN + INFO = 5 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = 9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLASR ', INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) + $ RETURN + IF( LSAME( SIDE, 'L' ) ) THEN +* +* FORM P * A +* + IF( LSAME( PIVOT, 'V' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 20 J = 1, M - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 10 I = 1, N + TEMP = A( J+1, I ) + A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) + A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) + 10 CONTINUE + END IF + 20 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 40 J = M - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 30 I = 1, N + TEMP = A( J+1, I ) + A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) + A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) + 30 CONTINUE + END IF + 40 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'T' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 60 J = 2, M + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 50 I = 1, N + TEMP = A( J, I ) + A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) + A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) + 50 CONTINUE + END IF + 60 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 80 J = M, 2, -1 + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 70 I = 1, N + TEMP = A( J, I ) + A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) + A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) + 70 CONTINUE + END IF + 80 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'B' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 100 J = 1, M - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 90 I = 1, N + TEMP = A( J, I ) + A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP + A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP + 90 CONTINUE + END IF + 100 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 120 J = M - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 110 I = 1, N + TEMP = A( J, I ) + A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP + A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP + 110 CONTINUE + END IF + 120 CONTINUE + END IF + END IF + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* FORM A * P' +* + IF( LSAME( PIVOT, 'V' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 140 J = 1, N - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 130 I = 1, M + TEMP = A( I, J+1 ) + A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) + A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) + 130 CONTINUE + END IF + 140 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 160 J = N - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 150 I = 1, M + TEMP = A( I, J+1 ) + A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) + A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) + 150 CONTINUE + END IF + 160 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'T' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 180 J = 2, N + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 170 I = 1, M + TEMP = A( I, J ) + A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) + A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) + 170 CONTINUE + END IF + 180 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 200 J = N, 2, -1 + CTEMP = C( J-1 ) + STEMP = S( J-1 ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 190 I = 1, M + TEMP = A( I, J ) + A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) + A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) + 190 CONTINUE + END IF + 200 CONTINUE + END IF + ELSE IF( LSAME( PIVOT, 'B' ) ) THEN + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 220 J = 1, N - 1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 210 I = 1, M + TEMP = A( I, J ) + A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP + A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP + 210 CONTINUE + END IF + 220 CONTINUE + ELSE IF( LSAME( DIRECT, 'B' ) ) THEN + DO 240 J = N - 1, 1, -1 + CTEMP = C( J ) + STEMP = S( J ) + IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN + DO 230 I = 1, M + TEMP = A( I, J ) + A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP + A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP + 230 CONTINUE + END IF + 240 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* END OF DLASR +* + END +CUT HERE............ +CAT > DLAEV2.F <<'CUT HERE............' + SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1 +* .. +* +* PURPOSE +* ======= +* +* DLAEV2 COMPUTES THE EIGENDECOMPOSITION OF A 2-BY-2 SYMMETRIC MATRIX +* [ A B ] +* [ B C ]. +* ON RETURN, RT1 IS THE EIGENVALUE OF LARGER ABSOLUTE VALUE, RT2 IS THE +* EIGENVALUE OF SMALLER ABSOLUTE VALUE, AND (CS1,SN1) IS THE UNIT RIGHT +* EIGENVECTOR FOR RT1, GIVING THE DECOMPOSITION +* +* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ] +* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ]. +* +* ARGUMENTS +* ========= +* +* A (INPUT) DOUBLE PRECISION +* THE (1,1) ENTRY OF THE 2-BY-2 MATRIX. +* +* B (INPUT) DOUBLE PRECISION +* THE (1,2) ENTRY AND THE CONJUGATE OF THE (2,1) ENTRY OF THE +* 2-BY-2 MATRIX. +* +* C (INPUT) DOUBLE PRECISION +* THE (2,2) ENTRY OF THE 2-BY-2 MATRIX. +* +* RT1 (OUTPUT) DOUBLE PRECISION +* THE EIGENVALUE OF LARGER ABSOLUTE VALUE. +* +* RT2 (OUTPUT) DOUBLE PRECISION +* THE EIGENVALUE OF SMALLER ABSOLUTE VALUE. +* +* CS1 (OUTPUT) DOUBLE PRECISION +* SN1 (OUTPUT) DOUBLE PRECISION +* THE VECTOR (CS1, SN1) IS A UNIT RIGHT EIGENVECTOR FOR RT1. +* +* FURTHER DETAILS +* =============== +* +* RT1 IS ACCURATE TO A FEW ULPS BARRING OVER/UNDERFLOW. +* +* RT2 MAY BE INACCURATE IF THERE IS MASSIVE CANCELLATION IN THE +* DETERMINANT A*C-B*B; HIGHER PRECISION OR CORRECTLY ROUNDED OR +* CORRECTLY TRUNCATED ARITHMETIC WOULD BE NEEDED TO COMPUTE RT2 +* ACCURATELY IN ALL CASES. +* +* CS1 AND SN1 ARE ACCURATE TO A FEW ULPS BARRING OVER/UNDERFLOW. +* +* OVERFLOW IS POSSIBLE ONLY IF RT1 IS WITHIN A FACTOR OF 5 OF OVERFLOW. +* UNDERFLOW IS HARMLESS IF THE INPUT DATA IS 0 OR EXCEEDS +* UNDERFLOW_THRESHOLD / MACHEPS. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER SGN1, SGN2 + DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM, + $ TB, TN +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS, SQRT +* .. +* .. EXECUTABLE STATEMENTS .. +* +* COMPUTE THE EIGENVALUES +* + SM = A + C + DF = A - C + ADF = ABS( DF ) + TB = B + B + AB = ABS( TB ) + IF( ABS( A ).GT.ABS( C ) ) THEN + ACMX = A + ACMN = C + ELSE + ACMX = C + ACMN = A + END IF + IF( ADF.GT.AB ) THEN + RT = ADF*SQRT( ONE+( AB / ADF )**2 ) + ELSE IF( ADF.LT.AB ) THEN + RT = AB*SQRT( ONE+( ADF / AB )**2 ) + ELSE +* +* INCLUDES CASE AB=ADF=0 +* + RT = AB*SQRT( TWO ) + END IF + IF( SM.LT.ZERO ) THEN + RT1 = HALF*( SM-RT ) + SGN1 = -1 +* +* ORDER OF EXECUTION IMPORTANT. +* TO GET FULLY ACCURATE SMALLER EIGENVALUE, +* NEXT LINE NEEDS TO BE EXECUTED IN HIGHER PRECISION. +* + RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B + ELSE IF( SM.GT.ZERO ) THEN + RT1 = HALF*( SM+RT ) + SGN1 = 1 +* +* ORDER OF EXECUTION IMPORTANT. +* TO GET FULLY ACCURATE SMALLER EIGENVALUE, +* NEXT LINE NEEDS TO BE EXECUTED IN HIGHER PRECISION. +* + RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B + ELSE +* +* INCLUDES CASE RT1 = RT2 = 0 +* + RT1 = HALF*RT + RT2 = -HALF*RT + SGN1 = 1 + END IF +* +* COMPUTE THE EIGENVECTOR +* + IF( DF.GE.ZERO ) THEN + CS = DF + RT + SGN2 = 1 + ELSE + CS = DF - RT + SGN2 = -1 + END IF + ACS = ABS( CS ) + IF( ACS.GT.AB ) THEN + CT = -TB / CS + SN1 = ONE / SQRT( ONE+CT*CT ) + CS1 = CT*SN1 + ELSE + IF( AB.EQ.ZERO ) THEN + CS1 = ONE + SN1 = ZERO + ELSE + TN = -CS / TB + CS1 = ONE / SQRT( ONE+TN*TN ) + SN1 = TN*CS1 + END IF + END IF + IF( SGN1.EQ.SGN2 ) THEN + TN = CS1 + CS1 = -SN1 + SN1 = TN + END IF + RETURN +* +* END OF DLAEV2 +* + END +CUT HERE............ +CAT > DLAZRO.F <<'CUT HERE............' + SUBROUTINE DLAZRO( M, N, ALPHA, BETA, A, LDA ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + INTEGER LDA, M, N + DOUBLE PRECISION ALPHA, BETA +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* PURPOSE +* ======= +* +* DLAZRO INITIALIZES A 2-D ARRAY A TO BETA ON THE DIAGONAL AND +* ALPHA ON THE OFFDIAGONALS. +* +* ARGUMENTS +* ========= +* +* M (INPUT) INTEGER +* THE NUMBER OF ROWS OF THE MATRIX A. M >= 0. +* +* N (INPUT) INTEGER +* THE NUMBER OF COLUMNS OF THE MATRIX A. N >= 0. +* +* ALPHA (INPUT) DOUBLE PRECISION +* THE CONSTANT TO WHICH THE OFFDIAGONAL ELEMENTS ARE TO BE SET. +* +* BETA (INPUT) DOUBLE PRECISION +* THE CONSTANT TO WHICH THE DIAGONAL ELEMENTS ARE TO BE SET. +* +* A (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* ON EXIT, THE LEADING M BY N SUBMATRIX OF A IS SET SUCH THAT +* A(I,J) = ALPHA, 1 <= I <= M, 1 <= J <= N, I <> J +* A(I,I) = BETA, 1 <= I <= MIN(M,N). +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,M). +* +* ===================================================================== +* +* .. LOCAL SCALARS .. + INTEGER I, J +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MIN +* .. +* .. EXECUTABLE STATEMENTS .. +* + DO 20 J = 1, N + DO 10 I = 1, M + A( I, J ) = ALPHA + 10 CONTINUE + 20 CONTINUE +* + DO 30 I = 1, MIN( M, N ) + A( I, I ) = BETA + 30 CONTINUE +* + RETURN +* +* END OF DLAZRO +* + END +CUT HERE............ +CAT > DORGTR.F <<'CUT HERE............' + SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* MARCH 31, 1993 +* +* .. SCALAR ARGUMENTS .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) +* .. +* +* PURPOSE +* ======= +* +* DORGTR GENERATES A REAL ORTHOGONAL MATRIX Q WHICH IS DEFINED AS THE +* PRODUCT OF N-1 ELEMENTARY REFLECTORS OF ORDER N, AS RETURNED BY +* DSYTRD: +* +* IF UPLO = 'U', Q = H(N-1) . . . H(2) H(1), +* +* IF UPLO = 'L', Q = H(1) H(2) . . . H(N-1). +* +* ARGUMENTS +* ========= +* +* UPLO (INPUT) CHARACTER*1 +* = 'U': UPPER TRIANGLE OF A CONTAINS ELEMENTARY REFLECTORS +* FROM DSYTRD; +* = 'L': LOWER TRIANGLE OF A CONTAINS ELEMENTARY REFLECTORS +* FROM DSYTRD. +* +* N (INPUT) INTEGER +* THE ORDER OF THE MATRIX Q. N >= 0. +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* ON ENTRY, THE VECTORS WHICH DEFINE THE ELEMENTARY REFLECTORS, +* AS RETURNED BY DSYTRD. +* ON EXIT, THE N-BY-N ORTHOGONAL MATRIX Q. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N). +* +* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) +* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY +* REFLECTOR H(I), AS RETURNED BY DSYTRD. +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK) +* ON EXIT, IF INFO = 0, WORK(1) RETURNS THE OPTIMAL LWORK. +* +* LWORK (INPUT) INTEGER +* THE DIMENSION OF THE ARRAY WORK. LWORK >= MAX(1,N-1). +* FOR OPTIMUM PERFORMANCE LWORK >= (N-1)*NB, WHERE NB IS +* THE OPTIMAL BLOCKSIZE. +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) +* .. +* .. LOCAL SCALARS .. + LOGICAL UPPER + INTEGER I, IINFO, J +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DORGQL, DORGQR, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.MAX( 1, N-1 ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGTR', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* + IF( UPPER ) THEN +* +* Q WAS DETERMINED BY A CALL TO DSYTRD WITH UPLO = 'U' +* +* SHIFT THE VECTORS WHICH DEFINE THE ELEMENTARY REFLECTORS ONE +* COLUMN TO THE LEFT, AND SET THE LAST ROW AND COLUMN OF Q TO +* THOSE OF THE UNIT MATRIX +* + DO 20 J = 1, N - 1 + DO 10 I = 1, J - 1 + A( I, J ) = A( I, J+1 ) + 10 CONTINUE + A( N, J ) = ZERO + 20 CONTINUE + DO 30 I = 1, N - 1 + A( I, N ) = ZERO + 30 CONTINUE + A( N, N ) = ONE +* +* GENERATE Q(1:N-1,1:N-1) +* + CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO ) +* + ELSE +* +* Q WAS DETERMINED BY A CALL TO DSYTRD WITH UPLO = 'L'. +* +* SHIFT THE VECTORS WHICH DEFINE THE ELEMENTARY REFLECTORS ONE +* COLUMN TO THE RIGHT, AND SET THE FIRST ROW AND COLUMN OF Q TO +* THOSE OF THE UNIT MATRIX +* + DO 50 J = N, 2, -1 + A( 1, J ) = ZERO + DO 40 I = J + 1, N + A( I, J ) = A( I, J-1 ) + 40 CONTINUE + 50 CONTINUE + A( 1, 1 ) = ONE + DO 60 I = 2, N + A( I, 1 ) = ZERO + 60 CONTINUE + IF( N.GT.1 ) THEN +* +* GENERATE Q(2:N,2:N) +* + CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, + $ LWORK, IINFO ) + END IF + END IF + RETURN +* +* END OF DORGTR +* + END +CUT HERE............ +CAT > DORGQR.F <<'CUT HERE............' + SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* MARCH 31, 1993 +* +* .. SCALAR ARGUMENTS .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) +* .. +* +* PURPOSE +* ======= +* +* DORGQR GENERATES AN M-BY-N REAL MATRIX Q WITH ORTHONORMAL COLUMNS, +* WHICH IS DEFINED AS THE FIRST N COLUMNS OF A PRODUCT OF K ELEMENTARY +* REFLECTORS OF ORDER M +* +* Q = H(1) H(2) . . . H(K) +* +* AS RETURNED BY DGEQRF. +* +* ARGUMENTS +* ========= +* +* M (INPUT) INTEGER +* THE NUMBER OF ROWS OF THE MATRIX Q. M >= 0. +* +* N (INPUT) INTEGER +* THE NUMBER OF COLUMNS OF THE MATRIX Q. M >= N >= 0. +* +* K (INPUT) INTEGER +* THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES THE +* MATRIX Q. N >= K >= 0. +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* ON ENTRY, THE I-TH COLUMN MUST CONTAIN THE VECTOR WHICH +* DEFINES THE ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS +* RETURNED BY DGEQRF IN THE FIRST K COLUMNS OF ITS ARRAY +* ARGUMENT A. +* ON EXIT, THE M-BY-N MATRIX Q. +* +* LDA (INPUT) INTEGER +* THE FIRST DIMENSION OF THE ARRAY A. LDA >= MAX(1,M). +* +* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K) +* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY +* REFLECTOR H(I), AS RETURNED BY DGEQRF. +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK) +* ON EXIT, IF INFO = 0, WORK(1) RETURNS THE OPTIMAL LWORK. +* +* LWORK (INPUT) INTEGER +* THE DIMENSION OF THE ARRAY WORK. LWORK >= MAX(1,N). +* FOR OPTIMUM PERFORMANCE LWORK >= N*NB, WHERE NB IS THE +* OPTIMAL BLOCKSIZE. +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAS AN ILLEGAL VALUE +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, NB, + $ NBMIN, NX +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN +* .. +* .. EXTERNAL FUNCTIONS .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGQR', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( N.LE.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* DETERMINE THE BLOCK SIZE. +* + NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* DETERMINE WHEN TO CROSS OVER FROM BLOCKED TO UNBLOCKED CODE. +* + NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* DETERMINE IF WORKSPACE IS LARGE ENOUGH FOR BLOCKED CODE. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* NOT ENOUGH WORKSPACE TO USE OPTIMAL NB: REDUCE NB AND +* DETERMINE THE MINIMUM VALUE OF NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* USE BLOCKED CODE AFTER THE LAST BLOCK. +* THE FIRST KK COLUMNS ARE HANDLED BY THE BLOCK METHOD. +* + KI = ( ( K-NX-1 ) / NB )*NB + KK = MIN( K, KI+NB ) +* +* SET A(1:KK,KK+1:N) TO ZERO. +* + DO 20 J = KK + 1, N + DO 10 I = 1, KK + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* USE UNBLOCKED CODE FOR THE LAST OR ONLY BLOCK. +* + IF( KK.LT.N ) + $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, + $ TAU( KK+1 ), WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* USE BLOCKED CODE +* + DO 50 I = KI + 1, 1, -NB + IB = MIN( NB, K-I+1 ) + IF( I+IB.LE.N ) THEN +* +* FORM THE TRIANGULAR FACTOR OF THE BLOCK REFLECTOR +* H = H(I) H(I+1) . . . H(I+IB-1) +* + CALL DLARFT( 'FORWARD', 'COLUMNWISE', M-I+1, IB, + $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) +* +* APPLY H TO A(I:M,I+IB:N) FROM THE LEFT +* + CALL DLARFB( 'LEFT', 'NO TRANSPOSE', 'FORWARD', + $ 'COLUMNWISE', M-I+1, N-I-IB+1, IB, + $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), + $ LDA, WORK( IB+1 ), LDWORK ) + END IF +* +* APPLY H TO ROWS I:M OF CURRENT BLOCK +* + CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, + $ IINFO ) +* +* SET ROWS 1:I-1 OF CURRENT BLOCK TO ZERO +* + DO 40 J = I, I + IB - 1 + DO 30 L = 1, I - 1 + A( L, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* END OF DORGQR +* + END +CUT HERE............ +CAT > DORG2R.F <<'CUT HERE............' + SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* FEBRUARY 29, 1992 +* +* .. SCALAR ARGUMENTS .. + INTEGER INFO, K, LDA, M, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* PURPOSE +* ======= +* +* DORG2R GENERATES AN M BY N REAL MATRIX Q WITH ORTHONORMAL COLUMNS, +* WHICH IS DEFINED AS THE FIRST N COLUMNS OF A PRODUCT OF K ELEMENTARY +* REFLECTORS OF ORDER M +* +* Q = H(1) H(2) . . . H(K) +* +* AS RETURNED BY DGEQRF. +* +* ARGUMENTS +* ========= +* +* M (INPUT) INTEGER +* THE NUMBER OF ROWS OF THE MATRIX Q. M >= 0. +* +* N (INPUT) INTEGER +* THE NUMBER OF COLUMNS OF THE MATRIX Q. M >= N >= 0. +* +* K (INPUT) INTEGER +* THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES THE +* MATRIX Q. N >= K >= 0. +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* ON ENTRY, THE I-TH COLUMN MUST CONTAIN THE VECTOR WHICH +* DEFINES THE ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS +* RETURNED BY DGEQRF IN THE FIRST K COLUMNS OF ITS ARRAY +* ARGUMENT A. +* ON EXIT, THE M-BY-N MATRIX Q. +* +* LDA (INPUT) INTEGER +* THE FIRST DIMENSION OF THE ARRAY A. LDA >= MAX(1,M). +* +* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K) +* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY +* REFLECTOR H(I), AS RETURNED BY DGEQRF. +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (N) +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAS AN ILLEGAL VALUE +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER I, J, L +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLARF, DSCAL, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORG2R', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( N.LE.0 ) + $ RETURN +* +* INITIALISE COLUMNS K+1:N TO COLUMNS OF THE UNIT MATRIX +* + DO 20 J = K + 1, N + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( J, J ) = ONE + 20 CONTINUE +* + DO 40 I = K, 1, -1 +* +* APPLY H(I) TO A(I:M,I:N) FROM THE LEFT +* + IF( I.LT.N ) THEN + A( I, I ) = ONE + CALL DLARF( 'LEFT', M-I+1, N-I, A( I, I ), 1, TAU( I ), + $ A( I, I+1 ), LDA, WORK ) + END IF + IF( I.LT.M ) + $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) + A( I, I ) = ONE - TAU( I ) +* +* SET A(1:I-1,I) TO ZERO +* + DO 30 L = 1, I - 1 + A( L, I ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* END OF DORG2R +* + END +CUT HERE............ +CAT > DORGQL.F <<'CUT HERE............' + SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* MARCH 31, 1993 +* +* .. SCALAR ARGUMENTS .. + INTEGER INFO, K, LDA, LWORK, M, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) +* .. +* +* PURPOSE +* ======= +* +* DORGQL GENERATES AN M-BY-N REAL MATRIX Q WITH ORTHONORMAL COLUMNS, +* WHICH IS DEFINED AS THE LAST N COLUMNS OF A PRODUCT OF K ELEMENTARY +* REFLECTORS OF ORDER M +* +* Q = H(K) . . . H(2) H(1) +* +* AS RETURNED BY DGEQLF. +* +* ARGUMENTS +* ========= +* +* M (INPUT) INTEGER +* THE NUMBER OF ROWS OF THE MATRIX Q. M >= 0. +* +* N (INPUT) INTEGER +* THE NUMBER OF COLUMNS OF THE MATRIX Q. M >= N >= 0. +* +* K (INPUT) INTEGER +* THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES THE +* MATRIX Q. N >= K >= 0. +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* ON ENTRY, THE (N-K+I)-TH COLUMN MUST CONTAIN THE VECTOR WHICH +* DEFINES THE ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS +* RETURNED BY DGEQLF IN THE LAST K COLUMNS OF ITS ARRAY +* ARGUMENT A. +* ON EXIT, THE M-BY-N MATRIX Q. +* +* LDA (INPUT) INTEGER +* THE FIRST DIMENSION OF THE ARRAY A. LDA >= MAX(1,M). +* +* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K) +* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY +* REFLECTOR H(I), AS RETURNED BY DGEQLF. +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK) +* ON EXIT, IF INFO = 0, WORK(1) RETURNS THE OPTIMAL LWORK. +* +* LWORK (INPUT) INTEGER +* THE DIMENSION OF THE ARRAY WORK. LWORK >= MAX(1,N). +* FOR OPTIMUM PERFORMANCE LWORK >= N*NB, WHERE NB IS THE +* OPTIMAL BLOCKSIZE. +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAS AN ILLEGAL VALUE +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, NB, NBMIN, + $ NX +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLARFB, DLARFT, DORG2L, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN +* .. +* .. EXTERNAL FUNCTIONS .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORGQL', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( N.LE.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* DETERMINE THE BLOCK SIZE. +* + NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 ) + NBMIN = 2 + NX = 0 + IWS = N + IF( NB.GT.1 .AND. NB.LT.K ) THEN +* +* DETERMINE WHEN TO CROSS OVER FROM BLOCKED TO UNBLOCKED CODE. +* + NX = MAX( 0, ILAENV( 3, 'DORGQL', ' ', M, N, K, -1 ) ) + IF( NX.LT.K ) THEN +* +* DETERMINE IF WORKSPACE IS LARGE ENOUGH FOR BLOCKED CODE. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* NOT ENOUGH WORKSPACE TO USE OPTIMAL NB: REDUCE NB AND +* DETERMINE THE MINIMUM VALUE OF NB. +* + NB = LWORK / LDWORK + NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) ) + END IF + END IF + END IF +* + IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN +* +* USE BLOCKED CODE AFTER THE FIRST BLOCK. +* THE LAST KK COLUMNS ARE HANDLED BY THE BLOCK METHOD. +* + KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB ) +* +* SET A(M-KK+1:M,1:N-KK) TO ZERO. +* + DO 20 J = 1, N - KK + DO 10 I = M - KK + 1, M + A( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + KK = 0 + END IF +* +* USE UNBLOCKED CODE FOR THE FIRST OR ONLY BLOCK. +* + CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO ) +* + IF( KK.GT.0 ) THEN +* +* USE BLOCKED CODE +* + DO 50 I = K - KK + 1, K, NB + IB = MIN( NB, K-I+1 ) + IF( N-K+I.GT.1 ) THEN +* +* FORM THE TRIANGULAR FACTOR OF THE BLOCK REFLECTOR +* H = H(I+IB-1) . . . H(I+1) H(I) +* + CALL DLARFT( 'BACKWARD', 'COLUMNWISE', M-K+I+IB-1, IB, + $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK ) +* +* APPLY H TO A(1:M-K+I+IB-1,1:N-K+I-1) FROM THE LEFT +* + CALL DLARFB( 'LEFT', 'NO TRANSPOSE', 'BACKWARD', + $ 'COLUMNWISE', M-K+I+IB-1, N-K+I-1, IB, + $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA, + $ WORK( IB+1 ), LDWORK ) + END IF +* +* APPLY H TO ROWS 1:M-K+I+IB-1 OF CURRENT BLOCK +* + CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA, + $ TAU( I ), WORK, IINFO ) +* +* SET ROWS M-K+I+IB:M OF CURRENT BLOCK TO ZERO +* + DO 40 J = N - K + I, N - K + I + IB - 1 + DO 30 L = M - K + I + IB, M + A( L, J ) = ZERO + 30 CONTINUE + 40 CONTINUE + 50 CONTINUE + END IF +* + WORK( 1 ) = IWS + RETURN +* +* END OF DORGQL +* + END +CUT HERE............ +CAT > DLARFB.F <<'CUT HERE............' + SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, + $ T, LDT, C, LDC, WORK, LDWORK ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* FEBRUARY 29, 1992 +* +* .. SCALAR ARGUMENTS .. + CHARACTER DIRECT, SIDE, STOREV, TRANS + INTEGER K, LDC, LDT, LDV, LDWORK, M, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), + $ WORK( LDWORK, * ) +* .. +* +* PURPOSE +* ======= +* +* DLARFB APPLIES A REAL BLOCK REFLECTOR H OR ITS TRANSPOSE H' TO A +* REAL M BY N MATRIX C, FROM EITHER THE LEFT OR THE RIGHT. +* +* ARGUMENTS +* ========= +* +* SIDE (INPUT) CHARACTER*1 +* = 'L': APPLY H OR H' FROM THE LEFT +* = 'R': APPLY H OR H' FROM THE RIGHT +* +* TRANS (INPUT) CHARACTER*1 +* = 'N': APPLY H (NO TRANSPOSE) +* = 'T': APPLY H' (TRANSPOSE) +* +* DIRECT (INPUT) CHARACTER*1 +* INDICATES HOW H IS FORMED FROM A PRODUCT OF ELEMENTARY +* REFLECTORS +* = 'F': H = H(1) H(2) . . . H(K) (FORWARD) +* = 'B': H = H(K) . . . H(2) H(1) (BACKWARD) +* +* STOREV (INPUT) CHARACTER*1 +* INDICATES HOW THE VECTORS WHICH DEFINE THE ELEMENTARY +* REFLECTORS ARE STORED: +* = 'C': COLUMNWISE +* = 'R': ROWWISE +* +* M (INPUT) INTEGER +* THE NUMBER OF ROWS OF THE MATRIX C. +* +* N (INPUT) INTEGER +* THE NUMBER OF COLUMNS OF THE MATRIX C. +* +* K (INPUT) INTEGER +* THE ORDER OF THE MATRIX T (= THE NUMBER OF ELEMENTARY +* REFLECTORS WHOSE PRODUCT DEFINES THE BLOCK REFLECTOR). +* +* V (INPUT) DOUBLE PRECISION ARRAY, DIMENSION +* (LDV,K) IF STOREV = 'C' +* (LDV,M) IF STOREV = 'R' AND SIDE = 'L' +* (LDV,N) IF STOREV = 'R' AND SIDE = 'R' +* THE MATRIX V. SEE FURTHER DETAILS. +* +* LDV (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY V. +* IF STOREV = 'C' AND SIDE = 'L', LDV >= MAX(1,M); +* IF STOREV = 'C' AND SIDE = 'R', LDV >= MAX(1,N); +* IF STOREV = 'R', LDV >= K. +* +* T (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDT,K) +* THE TRIANGULAR K BY K MATRIX T IN THE REPRESENTATION OF THE +* BLOCK REFLECTOR. +* +* LDT (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY T. LDT >= K. +* +* C (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDC,N) +* ON ENTRY, THE M BY N MATRIX C. +* ON EXIT, C IS OVERWRITTEN BY H*C OR H'*C OR C*H OR C*H'. +* +* LDC (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY C. LDA >= MAX(1,M). +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LDWORK,K) +* +* LDWORK (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY WORK. +* IF SIDE = 'L', LDWORK >= MAX(1,N); +* IF SIDE = 'R', LDWORK >= MAX(1,M). +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. LOCAL SCALARS .. + CHARACTER TRANST + INTEGER I, J +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DCOPY, DGEMM, DTRMM +* .. +* .. EXECUTABLE STATEMENTS .. +* +* QUICK RETURN IF POSSIBLE +* + IF( M.LE.0 .OR. N.LE.0 ) + $ RETURN +* + IF( LSAME( TRANS, 'N' ) ) THEN + TRANST = 'T' + ELSE + TRANST = 'N' + END IF +* + IF( LSAME( STOREV, 'C' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* LET V = ( V1 ) (FIRST K ROWS) +* ( V2 ) +* WHERE V1 IS UNIT LOWER TRIANGULAR. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* FORM H * C OR H' * C WHERE C = ( C1 ) +* ( C2 ) +* +* W := C' * V = (C1'*V1 + C2'*V2) (STORED IN WORK) +* +* W := C1' +* + DO 10 J = 1, K + CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 10 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', N, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C2'*V2 +* + CALL DGEMM( 'TRANSPOSE', 'NO TRANSPOSE', N, K, M-K, + $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T' OR W * T +* + CALL DTRMM( 'RIGHT', 'UPPER', TRANST, 'NON-UNIT', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W' +* + IF( M.GT.K ) THEN +* +* C2 := C2 - V2 * W' +* + CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M-K, N, K, + $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1' +* + CALL DTRMM( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', N, K, + $ ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W' +* + DO 30 J = 1, K + DO 20 I = 1, N + C( J, I ) = C( J, I ) - WORK( I, J ) + 20 CONTINUE + 30 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* FORM C * H OR C * H' WHERE C = ( C1 C2 ) +* +* W := C * V = (C1*V1 + C2*V2) (STORED IN WORK) +* +* W := C1 +* + DO 40 J = 1, K + CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) + 40 CONTINUE +* +* W := W * V1 +* + CALL DTRMM( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', M, + $ K, ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C2 * V2 +* + CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T OR W * T' +* + CALL DTRMM( 'RIGHT', 'UPPER', TRANS, 'NON-UNIT', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V' +* + IF( N.GT.K ) THEN +* +* C2 := C2 - W * V2' +* + CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M, N-K, K, + $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1' +* + CALL DTRMM( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', M, K, + $ ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 60 J = 1, K + DO 50 I = 1, M + C( I, J ) = C( I, J ) - WORK( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF +* + ELSE +* +* LET V = ( V1 ) +* ( V2 ) (LAST K ROWS) +* WHERE V2 IS UNIT UPPER TRIANGULAR. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* FORM H * C OR H' * C WHERE C = ( C1 ) +* ( C2 ) +* +* W := C' * V = (C1'*V1 + C2'*V2) (STORED IN WORK) +* +* W := C2' +* + DO 70 J = 1, K + CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + 70 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', N, + $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C1'*V1 +* + CALL DGEMM( 'TRANSPOSE', 'NO TRANSPOSE', N, K, M-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T' OR W * T +* + CALL DTRMM( 'RIGHT', 'LOWER', TRANST, 'NON-UNIT', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V * W' +* + IF( M.GT.K ) THEN +* +* C1 := C1 - V1 * W' +* + CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M-K, N, K, + $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) + END IF +* +* W := W * V2' +* + CALL DTRMM( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', N, K, + $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) +* +* C2 := C2 - W' +* + DO 90 J = 1, K + DO 80 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) + 80 CONTINUE + 90 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* FORM C * H OR C * H' WHERE C = ( C1 C2 ) +* +* W := C * V = (C1*V1 + C2*V2) (STORED IN WORK) +* +* W := C2 +* + DO 100 J = 1, K + CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + 100 CONTINUE +* +* W := W * V2 +* + CALL DTRMM( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', M, + $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C1 * V1 +* + CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T OR W * T' +* + CALL DTRMM( 'RIGHT', 'LOWER', TRANS, 'NON-UNIT', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V' +* + IF( N.GT.K ) THEN +* +* C1 := C1 - W * V1' +* + CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) + END IF +* +* W := W * V2' +* + CALL DTRMM( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', M, K, + $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) +* +* C2 := C2 - W +* + DO 120 J = 1, K + DO 110 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) + 110 CONTINUE + 120 CONTINUE + END IF + END IF +* + ELSE IF( LSAME( STOREV, 'R' ) ) THEN +* + IF( LSAME( DIRECT, 'F' ) ) THEN +* +* LET V = ( V1 V2 ) (V1: FIRST K COLUMNS) +* WHERE V1 IS UNIT UPPER TRIANGULAR. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* FORM H * C OR H' * C WHERE C = ( C1 ) +* ( C2 ) +* +* W := C' * V' = (C1'*V1' + C2'*V2') (STORED IN WORK) +* +* W := C1' +* + DO 130 J = 1, K + CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) + 130 CONTINUE +* +* W := W * V1' +* + CALL DTRMM( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', N, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C2'*V2' +* + CALL DGEMM( 'TRANSPOSE', 'TRANSPOSE', N, K, M-K, ONE, + $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, + $ WORK, LDWORK ) + END IF +* +* W := W * T' OR W * T +* + CALL DTRMM( 'RIGHT', 'UPPER', TRANST, 'NON-UNIT', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V' * W' +* + IF( M.GT.K ) THEN +* +* C2 := C2 - V2' * W' +* + CALL DGEMM( 'TRANSPOSE', 'TRANSPOSE', M-K, N, K, -ONE, + $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, + $ C( K+1, 1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', N, + $ K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W' +* + DO 150 J = 1, K + DO 140 I = 1, N + C( J, I ) = C( J, I ) - WORK( I, J ) + 140 CONTINUE + 150 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* FORM C * H OR C * H' WHERE C = ( C1 C2 ) +* +* W := C * V' = (C1*V1' + C2*V2') (STORED IN WORK) +* +* W := C1 +* + DO 160 J = 1, K + CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) + 160 CONTINUE +* +* W := W * V1' +* + CALL DTRMM( 'RIGHT', 'UPPER', 'TRANSPOSE', 'UNIT', M, K, + $ ONE, V, LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C2 * V2' +* + CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M, K, N-K, + $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, + $ ONE, WORK, LDWORK ) + END IF +* +* W := W * T OR W * T' +* + CALL DTRMM( 'RIGHT', 'UPPER', TRANS, 'NON-UNIT', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( N.GT.K ) THEN +* +* C2 := C2 - W * V2 +* + CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', M, N-K, K, + $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, + $ C( 1, K+1 ), LDC ) + END IF +* +* W := W * V1 +* + CALL DTRMM( 'RIGHT', 'UPPER', 'NO TRANSPOSE', 'UNIT', M, + $ K, ONE, V, LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 180 J = 1, K + DO 170 I = 1, M + C( I, J ) = C( I, J ) - WORK( I, J ) + 170 CONTINUE + 180 CONTINUE +* + END IF +* + ELSE +* +* LET V = ( V1 V2 ) (V2: LAST K COLUMNS) +* WHERE V2 IS UNIT LOWER TRIANGULAR. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* FORM H * C OR H' * C WHERE C = ( C1 ) +* ( C2 ) +* +* W := C' * V' = (C1'*V1' + C2'*V2') (STORED IN WORK) +* +* W := C2' +* + DO 190 J = 1, K + CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) + 190 CONTINUE +* +* W := W * V2' +* + CALL DTRMM( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', N, K, + $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) + IF( M.GT.K ) THEN +* +* W := W + C1'*V1' +* + CALL DGEMM( 'TRANSPOSE', 'TRANSPOSE', N, K, M-K, ONE, + $ C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T' OR W * T +* + CALL DTRMM( 'RIGHT', 'LOWER', TRANST, 'NON-UNIT', N, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - V' * W' +* + IF( M.GT.K ) THEN +* +* C1 := C1 - V1' * W' +* + CALL DGEMM( 'TRANSPOSE', 'TRANSPOSE', M-K, N, K, -ONE, + $ V, LDV, WORK, LDWORK, ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', N, + $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) +* +* C2 := C2 - W' +* + DO 210 J = 1, K + DO 200 I = 1, N + C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) + 200 CONTINUE + 210 CONTINUE +* + ELSE IF( LSAME( SIDE, 'R' ) ) THEN +* +* FORM C * H OR C * H' WHERE C = ( C1 C2 ) +* +* W := C * V' = (C1*V1' + C2*V2') (STORED IN WORK) +* +* W := C2 +* + DO 220 J = 1, K + CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) + 220 CONTINUE +* +* W := W * V2' +* + CALL DTRMM( 'RIGHT', 'LOWER', 'TRANSPOSE', 'UNIT', M, K, + $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) + IF( N.GT.K ) THEN +* +* W := W + C1 * V1' +* + CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', M, K, N-K, + $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) + END IF +* +* W := W * T OR W * T' +* + CALL DTRMM( 'RIGHT', 'LOWER', TRANS, 'NON-UNIT', M, K, + $ ONE, T, LDT, WORK, LDWORK ) +* +* C := C - W * V +* + IF( N.GT.K ) THEN +* +* C1 := C1 - W * V1 +* + CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', M, N-K, K, + $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) + END IF +* +* W := W * V2 +* + CALL DTRMM( 'RIGHT', 'LOWER', 'NO TRANSPOSE', 'UNIT', M, + $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) +* +* C1 := C1 - W +* + DO 240 J = 1, K + DO 230 I = 1, M + C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) + 230 CONTINUE + 240 CONTINUE +* + END IF +* + END IF + END IF +* + RETURN +* +* END OF DLARFB +* + END +CUT HERE............ +CAT > DLARFT.F <<'CUT HERE............' + SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* FEBRUARY 29, 1992 +* +* .. SCALAR ARGUMENTS .. + CHARACTER DIRECT, STOREV + INTEGER K, LDT, LDV, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) +* .. +* +* PURPOSE +* ======= +* +* DLARFT FORMS THE TRIANGULAR FACTOR T OF A REAL BLOCK REFLECTOR H +* OF ORDER N, WHICH IS DEFINED AS A PRODUCT OF K ELEMENTARY REFLECTORS. +* +* IF DIRECT = 'F', H = H(1) H(2) . . . H(K) AND T IS UPPER TRIANGULAR; +* +* IF DIRECT = 'B', H = H(K) . . . H(2) H(1) AND T IS LOWER TRIANGULAR. +* +* IF STOREV = 'C', THE VECTOR WHICH DEFINES THE ELEMENTARY REFLECTOR +* H(I) IS STORED IN THE I-TH COLUMN OF THE ARRAY V, AND +* +* H = I - V * T * V' +* +* IF STOREV = 'R', THE VECTOR WHICH DEFINES THE ELEMENTARY REFLECTOR +* H(I) IS STORED IN THE I-TH ROW OF THE ARRAY V, AND +* +* H = I - V' * T * V +* +* ARGUMENTS +* ========= +* +* DIRECT (INPUT) CHARACTER*1 +* SPECIFIES THE ORDER IN WHICH THE ELEMENTARY REFLECTORS ARE +* MULTIPLIED TO FORM THE BLOCK REFLECTOR: +* = 'F': H = H(1) H(2) . . . H(K) (FORWARD) +* = 'B': H = H(K) . . . H(2) H(1) (BACKWARD) +* +* STOREV (INPUT) CHARACTER*1 +* SPECIFIES HOW THE VECTORS WHICH DEFINE THE ELEMENTARY +* REFLECTORS ARE STORED (SEE ALSO FURTHER DETAILS): +* = 'C': COLUMNWISE +* = 'R': ROWWISE +* +* N (INPUT) INTEGER +* THE ORDER OF THE BLOCK REFLECTOR H. N >= 0. +* +* K (INPUT) INTEGER +* THE ORDER OF THE TRIANGULAR FACTOR T (= THE NUMBER OF +* ELEMENTARY REFLECTORS). K >= 1. +* +* V (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION +* (LDV,K) IF STOREV = 'C' +* (LDV,N) IF STOREV = 'R' +* THE MATRIX V. SEE FURTHER DETAILS. +* +* LDV (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY V. +* IF STOREV = 'C', LDV >= MAX(1,N); IF STOREV = 'R', LDV >= K. +* +* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K) +* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY +* REFLECTOR H(I). +* +* T (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDT,K) +* THE K BY K TRIANGULAR FACTOR T OF THE BLOCK REFLECTOR. +* IF DIRECT = 'F', T IS UPPER TRIANGULAR; IF DIRECT = 'B', T IS +* LOWER TRIANGULAR. THE REST OF THE ARRAY IS NOT USED. +* +* LDT (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY T. LDT >= K. +* +* FURTHER DETAILS +* =============== +* +* THE SHAPE OF THE MATRIX V AND THE STORAGE OF THE VECTORS WHICH DEFINE +* THE H(I) IS BEST ILLUSTRATED BY THE FOLLOWING EXAMPLE WITH N = 5 AND +* K = 3. THE ELEMENTS EQUAL TO 1 ARE NOT STORED; THE CORRESPONDING +* ARRAY ELEMENTS ARE MODIFIED BUT RESTORED ON EXIT. THE REST OF THE +* ARRAY IS NOT USED. +* +* DIRECT = 'F' AND STOREV = 'C': DIRECT = 'F' AND STOREV = 'R': +* +* V = ( 1 ) V = ( 1 V1 V1 V1 V1 ) +* ( V1 1 ) ( 1 V2 V2 V2 ) +* ( V1 V2 1 ) ( 1 V3 V3 ) +* ( V1 V2 V3 ) +* ( V1 V2 V3 ) +* +* DIRECT = 'B' AND STOREV = 'C': DIRECT = 'B' AND STOREV = 'R': +* +* V = ( V1 V2 V3 ) V = ( V1 V1 1 ) +* ( V1 V2 V3 ) ( V2 V2 V2 1 ) +* ( 1 V2 V3 ) ( V3 V3 V3 V3 1 ) +* ( 1 V3 ) +* ( 1 ) +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER I, J + DOUBLE PRECISION VII +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DGEMV, DTRMV +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. EXECUTABLE STATEMENTS .. +* +* QUICK RETURN IF POSSIBLE +* + IF( N.EQ.0 ) + $ RETURN +* + IF( LSAME( DIRECT, 'F' ) ) THEN + DO 20 I = 1, K + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(I) = I +* + DO 10 J = 1, I + T( J, I ) = ZERO + 10 CONTINUE + ELSE +* +* GENERAL CASE +* + VII = V( I, I ) + V( I, I ) = ONE + IF( LSAME( STOREV, 'C' ) ) THEN +* +* T(1:I-1,I) := - TAU(I) * V(I:N,1:I-1)' * V(I:N,I) +* + CALL DGEMV( 'TRANSPOSE', N-I+1, I-1, -TAU( I ), + $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, + $ T( 1, I ), 1 ) + ELSE +* +* T(1:I-1,I) := - TAU(I) * V(1:I-1,I:N) * V(I,I:N)' +* + CALL DGEMV( 'NO TRANSPOSE', I-1, N-I+1, -TAU( I ), + $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, + $ T( 1, I ), 1 ) + END IF + V( I, I ) = VII +* +* T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) +* + CALL DTRMV( 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', I-1, T, + $ LDT, T( 1, I ), 1 ) + T( I, I ) = TAU( I ) + END IF + 20 CONTINUE + ELSE + DO 40 I = K, 1, -1 + IF( TAU( I ).EQ.ZERO ) THEN +* +* H(I) = I +* + DO 30 J = I, K + T( J, I ) = ZERO + 30 CONTINUE + ELSE +* +* GENERAL CASE +* + IF( I.LT.K ) THEN + IF( LSAME( STOREV, 'C' ) ) THEN + VII = V( N-K+I, I ) + V( N-K+I, I ) = ONE +* +* T(I+1:K,I) := +* - TAU(I) * V(1:N-K+I,I+1:K)' * V(1:N-K+I,I) +* + CALL DGEMV( 'TRANSPOSE', N-K+I, K-I, -TAU( I ), + $ V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO, + $ T( I+1, I ), 1 ) + V( N-K+I, I ) = VII + ELSE + VII = V( I, N-K+I ) + V( I, N-K+I ) = ONE +* +* T(I+1:K,I) := +* - TAU(I) * V(I+1:K,1:N-K+I) * V(I,1:N-K+I)' +* + CALL DGEMV( 'NO TRANSPOSE', K-I, N-K+I, -TAU( I ), + $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, + $ T( I+1, I ), 1 ) + V( I, N-K+I ) = VII + END IF +* +* T(I+1:K,I) := T(I+1:K,I+1:K) * T(I+1:K,I) +* + CALL DTRMV( 'LOWER', 'NO TRANSPOSE', 'NON-UNIT', K-I, + $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) + END IF + T( I, I ) = TAU( I ) + END IF + 40 CONTINUE + END IF + RETURN +* +* END OF DLARFT +* + END +CUT HERE............ +CAT > DORG2L.F <<'CUT HERE............' + SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* FEBRUARY 29, 1992 +* +* .. SCALAR ARGUMENTS .. + INTEGER INFO, K, LDA, M, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) +* .. +* +* PURPOSE +* ======= +* +* DORG2L GENERATES AN M BY N REAL MATRIX Q WITH ORTHONORMAL COLUMNS, +* WHICH IS DEFINED AS THE LAST N COLUMNS OF A PRODUCT OF K ELEMENTARY +* REFLECTORS OF ORDER M +* +* Q = H(K) . . . H(2) H(1) +* +* AS RETURNED BY DGEQLF. +* +* ARGUMENTS +* ========= +* +* M (INPUT) INTEGER +* THE NUMBER OF ROWS OF THE MATRIX Q. M >= 0. +* +* N (INPUT) INTEGER +* THE NUMBER OF COLUMNS OF THE MATRIX Q. M >= N >= 0. +* +* K (INPUT) INTEGER +* THE NUMBER OF ELEMENTARY REFLECTORS WHOSE PRODUCT DEFINES THE +* MATRIX Q. N >= K >= 0. +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* ON ENTRY, THE (N-K+I)-TH COLUMN MUST CONTAIN THE VECTOR WHICH +* DEFINES THE ELEMENTARY REFLECTOR H(I), FOR I = 1,2,...,K, AS +* RETURNED BY DGEQLF IN THE LAST K COLUMNS OF ITS ARRAY +* ARGUMENT A. +* ON EXIT, THE M BY N MATRIX Q. +* +* LDA (INPUT) INTEGER +* THE FIRST DIMENSION OF THE ARRAY A. LDA >= MAX(1,M). +* +* TAU (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (K) +* TAU(I) MUST CONTAIN THE SCALAR FACTOR OF THE ELEMENTARY +* REFLECTOR H(I), AS RETURNED BY DGEQLF. +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (N) +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAS AN ILLEGAL VALUE +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER I, II, J, L +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLARF, DSCAL, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT ARGUMENTS +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 .OR. N.GT.M ) THEN + INFO = -2 + ELSE IF( K.LT.0 .OR. K.GT.N ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -5 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DORG2L', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( N.LE.0 ) + $ RETURN +* +* INITIALISE COLUMNS 1:N-K TO COLUMNS OF THE UNIT MATRIX +* + DO 20 J = 1, N - K + DO 10 L = 1, M + A( L, J ) = ZERO + 10 CONTINUE + A( M-N+J, J ) = ONE + 20 CONTINUE +* + DO 40 I = 1, K + II = N - K + I +* +* APPLY H(I) TO A(1:M-K+I,1:N-K+I) FROM THE LEFT +* + A( M-N+II, II ) = ONE + CALL DLARF( 'LEFT', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A, + $ LDA, WORK ) + CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 ) + A( M-N+II, II ) = ONE - TAU( I ) +* +* SET A(M-K+I+1:M,N-K+I) TO ZERO +* + DO 30 L = M - N + II + 1, M + A( L, II ) = ZERO + 30 CONTINUE + 40 CONTINUE + RETURN +* +* END OF DORG2L +* + END +CUT HERE............ +CAT > DLARF.F <<'CUT HERE............' + SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* FEBRUARY 29, 1992 +* +* .. SCALAR ARGUMENTS .. + CHARACTER SIDE + INTEGER INCV, LDC, M, N + DOUBLE PRECISION TAU +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) +* .. +* +* PURPOSE +* ======= +* +* DLARF APPLIES A REAL ELEMENTARY REFLECTOR H TO A REAL M BY N MATRIX +* C, FROM EITHER THE LEFT OR THE RIGHT. H IS REPRESENTED IN THE FORM +* +* H = I - TAU * V * V' +* +* WHERE TAU IS A REAL SCALAR AND V IS A REAL VECTOR. +* +* IF TAU = 0, THEN H IS TAKEN TO BE THE UNIT MATRIX. +* +* ARGUMENTS +* ========= +* +* SIDE (INPUT) CHARACTER*1 +* = 'L': FORM H * C +* = 'R': FORM C * H +* +* M (INPUT) INTEGER +* THE NUMBER OF ROWS OF THE MATRIX C. +* +* N (INPUT) INTEGER +* THE NUMBER OF COLUMNS OF THE MATRIX C. +* +* V (INPUT) DOUBLE PRECISION ARRAY, DIMENSION +* (1 + (M-1)*ABS(INCV)) IF SIDE = 'L' +* OR (1 + (N-1)*ABS(INCV)) IF SIDE = 'R' +* THE VECTOR V IN THE REPRESENTATION OF H. V IS NOT USED IF +* TAU = 0. +* +* INCV (INPUT) INTEGER +* THE INCREMENT BETWEEN ELEMENTS OF V. INCV <> 0. +* +* TAU (INPUT) DOUBLE PRECISION +* THE VALUE TAU IN THE REPRESENTATION OF H. +* +* C (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDC,N) +* ON ENTRY, THE M BY N MATRIX C. +* ON EXIT, C IS OVERWRITTEN BY THE MATRIX H * C IF SIDE = 'L', +* OR C * H IF SIDE = 'R'. +* +* LDC (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY C. LDC >= MAX(1,M). +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION +* (N) IF SIDE = 'L' +* OR (M) IF SIDE = 'R' +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DGEMV, DGER +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. EXECUTABLE STATEMENTS .. +* + IF( LSAME( SIDE, 'L' ) ) THEN +* +* FORM H * C +* + IF( TAU.NE.ZERO ) THEN +* +* W := C' * V +* + CALL DGEMV( 'TRANSPOSE', M, N, ONE, C, LDC, V, INCV, ZERO, + $ WORK, 1 ) +* +* C := C - V * W' +* + CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) + END IF + ELSE +* +* FORM C * H +* + IF( TAU.NE.ZERO ) THEN +* +* W := C * V +* + CALL DGEMV( 'NO TRANSPOSE', M, N, ONE, C, LDC, V, INCV, + $ ZERO, WORK, 1 ) +* +* C := C - W * V' +* + CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) + END IF + END IF + RETURN +* +* END OF DLARF +* + END +CUT HERE............ +CAT > DLACPY.F <<'CUT HERE............' + SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* FEBRUARY 29, 1992 +* +* .. SCALAR ARGUMENTS .. + CHARACTER UPLO + INTEGER LDA, LDB, M, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* PURPOSE +* ======= +* +* DLACPY COPIES ALL OR PART OF A TWO-DIMENSIONAL MATRIX A TO ANOTHER +* MATRIX B. +* +* ARGUMENTS +* ========= +* +* UPLO (INPUT) CHARACTER*1 +* SPECIFIES THE PART OF THE MATRIX A TO BE COPIED TO B. +* = 'U': UPPER TRIANGULAR PART +* = 'L': LOWER TRIANGULAR PART +* OTHERWISE: ALL OF THE MATRIX A +* +* M (INPUT) INTEGER +* THE NUMBER OF ROWS OF THE MATRIX A. M >= 0. +* +* N (INPUT) INTEGER +* THE NUMBER OF COLUMNS OF THE MATRIX A. N >= 0. +* +* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* THE M BY N MATRIX A. IF UPLO = 'U', ONLY THE UPPER TRIANGLE +* OR TRAPEZOID IS ACCESSED; IF UPLO = 'L', ONLY THE LOWER +* TRIANGLE OR TRAPEZOID IS ACCESSED. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,M). +* +* B (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDB,N) +* ON EXIT, B = A IN THE LOCATIONS SPECIFIED BY UPLO. +* +* LDB (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY B. LDB >= MAX(1,M). +* +* ===================================================================== +* +* .. LOCAL SCALARS .. + INTEGER I, J +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MIN +* .. +* .. EXECUTABLE STATEMENTS .. +* + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, MIN( J, M ) + B( I, J ) = A( I, J ) + 10 CONTINUE + 20 CONTINUE + ELSE IF( LSAME( UPLO, 'L' ) ) THEN + DO 40 J = 1, N + DO 30 I = J, M + B( I, J ) = A( I, J ) + 30 CONTINUE + 40 CONTINUE + ELSE + DO 60 J = 1, N + DO 50 I = 1, M + B( I, J ) = A( I, J ) + 50 CONTINUE + 60 CONTINUE + END IF + RETURN +* +* END OF DLACPY +* + END +CUT HERE............ +CAT > DSTERF.F <<'CUT HERE............' + SUBROUTINE DSTERF( N, D, E, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* MARCH 31, 1993 +* +* .. SCALAR ARGUMENTS .. + INTEGER INFO, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION D( * ), E( * ) +* .. +* +* PURPOSE +* ======= +* +* DSTERF COMPUTES ALL EIGENVALUES OF A SYMMETRIC TRIDIAGONAL MATRIX +* USING THE PAL-WALKER-KAHAN VARIANT OF THE QL OR QR ALGORITHM. +* +* ARGUMENTS +* ========= +* +* N (INPUT) INTEGER +* THE ORDER OF THE MATRIX. N >= 0. +* +* D (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* ON ENTRY, THE N DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX. +* ON EXIT, IF INFO = 0, THE EIGENVALUES IN ASCENDING ORDER. +* +* E (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) +* ON ENTRY, THE (N-1) SUBDIAGONAL ELEMENTS OF THE TRIDIAGONAL +* MATRIX. +* ON EXIT, E HAS BEEN DESTROYED. +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE +* > 0: THE ALGORITHM FAILED TO FIND ALL OF THE EIGENVALUES IN +* A TOTAL OF 30*N ITERATIONS; IF INFO = I, THEN I +* ELEMENTS OF E HAVE NOT CONVERGED TO ZERO. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO, ONE, TWO + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 ) + INTEGER MAXIT + PARAMETER ( MAXIT = 30 ) +* .. +* .. LOCAL SCALARS .. + INTEGER I, II, J, JTOT, K, L, L1, LEND, LENDM1, LENDP1, + $ LM1, M, MM1, NM1, NMAXIT + DOUBLE PRECISION ALPHA, BB, C, EPS, GAMMA, OLDC, OLDGAM, P, R, + $ RT1, RT2, RTE, S, SIGMA, TST +* .. +* .. EXTERNAL FUNCTIONS .. + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL DLAMCH, DLAPY2 +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLAE2, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS, SIGN, SQRT +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 +* +* QUICK RETURN IF POSSIBLE +* + IF( N.LT.0 ) THEN + INFO = -1 + CALL XERBLA( 'DSTERF', -INFO ) + RETURN + END IF + IF( N.LE.1 ) + $ RETURN +* +* DETERMINE THE UNIT ROUNDOFF FOR THIS ENVIRONMENT. +* + EPS = DLAMCH( 'E' ) +* +* COMPUTE THE EIGENVALUES OF THE TRIDIAGONAL MATRIX. +* + DO 10 I = 1, N - 1 + E( I ) = E( I )**2 + 10 CONTINUE +* + NMAXIT = N*MAXIT + SIGMA = ZERO + JTOT = 0 +* +* DETERMINE WHERE THE MATRIX SPLITS AND CHOOSE QL OR QR ITERATION +* FOR EACH BLOCK, ACCORDING TO WHETHER TOP OR BOTTOM DIAGONAL +* ELEMENT IS SMALLER. +* + L1 = 1 + NM1 = N - 1 +* + 20 CONTINUE + IF( L1.GT.N ) + $ GO TO 170 + IF( L1.GT.1 ) + $ E( L1-1 ) = ZERO + IF( L1.LE.NM1 ) THEN + DO 30 M = L1, NM1 + TST = SQRT( ABS( E( M ) ) ) + IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) ) + $ GO TO 40 + 30 CONTINUE + END IF + M = N +* + 40 CONTINUE + L = L1 + LEND = M + IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN + L = LEND + LEND = L1 + END IF + L1 = M + 1 +* + IF( LEND.GE.L ) THEN +* +* QL ITERATION +* +* LOOK FOR SMALL SUBDIAGONAL ELEMENT. +* + 50 CONTINUE + IF( L.NE.LEND ) THEN + LENDM1 = LEND - 1 + DO 60 M = L, LENDM1 + TST = SQRT( ABS( E( M ) ) ) + IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M+1 ) ) ) ) + $ GO TO 70 + 60 CONTINUE + END IF +* + M = LEND +* + 70 CONTINUE + IF( M.LT.LEND ) + $ E( M ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 90 +* +* IF REMAINING MATRIX IS 2 BY 2, USE DLAE2 TO COMPUTE ITS +* EIGENVALUES. +* + IF( M.EQ.L+1 ) THEN + RTE = SQRT( E( L ) ) + CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 ) + D( L ) = RT1 + D( L+1 ) = RT2 + E( L ) = ZERO + L = L + 2 + IF( L.LE.LEND ) + $ GO TO 50 + GO TO 20 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 150 + JTOT = JTOT + 1 +* +* FORM SHIFT. +* + RTE = SQRT( E( L ) ) + SIGMA = ( D( L+1 )-P ) / ( TWO*RTE ) + R = DLAPY2( SIGMA, ONE ) + SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) +* + C = ONE + S = ZERO + GAMMA = D( M ) - SIGMA + P = GAMMA*GAMMA +* +* INNER LOOP +* + MM1 = M - 1 + DO 80 I = MM1, L, -1 + BB = E( I ) + R = P + BB + IF( I.NE.M-1 ) + $ E( I+1 ) = S*R + OLDC = C + C = P / R + S = BB / R + OLDGAM = GAMMA + ALPHA = D( I ) + GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM + D( I+1 ) = OLDGAM + ( ALPHA-GAMMA ) + IF( C.NE.ZERO ) THEN + P = ( GAMMA*GAMMA ) / C + ELSE + P = OLDC*BB + END IF + 80 CONTINUE +* + E( L ) = S*P + D( L ) = SIGMA + GAMMA + GO TO 50 +* +* EIGENVALUE FOUND. +* + 90 CONTINUE + D( L ) = P +* + L = L + 1 + IF( L.LE.LEND ) + $ GO TO 50 + GO TO 20 +* + ELSE +* +* QR ITERATION +* +* LOOK FOR SMALL SUPERDIAGONAL ELEMENT. +* + 100 CONTINUE + IF( L.NE.LEND ) THEN + LENDP1 = LEND + 1 + DO 110 M = L, LENDP1, -1 + TST = SQRT( ABS( E( M-1 ) ) ) + IF( TST.LE.EPS*( ABS( D( M ) )+ABS( D( M-1 ) ) ) ) + $ GO TO 120 + 110 CONTINUE + END IF +* + M = LEND +* + 120 CONTINUE + IF( M.GT.LEND ) + $ E( M-1 ) = ZERO + P = D( L ) + IF( M.EQ.L ) + $ GO TO 140 +* +* IF REMAINING MATRIX IS 2 BY 2, USE DLAE2 TO COMPUTE ITS +* EIGENVALUES. +* + IF( M.EQ.L-1 ) THEN + RTE = SQRT( E( L-1 ) ) + CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 ) + D( L ) = RT1 + D( L-1 ) = RT2 + E( L-1 ) = ZERO + L = L - 2 + IF( L.GE.LEND ) + $ GO TO 100 + GO TO 20 + END IF +* + IF( JTOT.EQ.NMAXIT ) + $ GO TO 150 + JTOT = JTOT + 1 +* +* FORM SHIFT. +* + RTE = SQRT( E( L-1 ) ) + SIGMA = ( D( L-1 )-P ) / ( TWO*RTE ) + R = DLAPY2( SIGMA, ONE ) + SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) ) +* + C = ONE + S = ZERO + GAMMA = D( M ) - SIGMA + P = GAMMA*GAMMA +* +* INNER LOOP +* + LM1 = L - 1 + DO 130 I = M, LM1 + BB = E( I ) + R = P + BB + IF( I.NE.M ) + $ E( I-1 ) = S*R + OLDC = C + C = P / R + S = BB / R + OLDGAM = GAMMA + ALPHA = D( I+1 ) + GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM + D( I ) = OLDGAM + ( ALPHA-GAMMA ) + IF( C.NE.ZERO ) THEN + P = ( GAMMA*GAMMA ) / C + ELSE + P = OLDC*BB + END IF + 130 CONTINUE +* + E( LM1 ) = S*P + D( L ) = SIGMA + GAMMA + GO TO 100 +* +* EIGENVALUE FOUND. +* + 140 CONTINUE + D( L ) = P +* + L = L - 1 + IF( L.GE.LEND ) + $ GO TO 100 + GO TO 20 +* + END IF +* +* SET ERROR -- NO CONVERGENCE TO AN EIGENVALUE AFTER A TOTAL +* OF N*MAXIT ITERATIONS. +* + 150 CONTINUE + DO 160 I = 1, N - 1 + IF( E( I ).NE.ZERO ) + $ INFO = INFO + 1 + 160 CONTINUE + RETURN +* +* SORT EIGENVALUES IN INCREASING ORDER. +* + 170 CONTINUE + DO 190 II = 2, N + I = II - 1 + K = I + P = D( I ) + DO 180 J = II, N + IF( D( J ).LT.P ) THEN + K = J + P = D( J ) + END IF + 180 CONTINUE + IF( K.NE.I ) THEN + D( K ) = D( I ) + D( I ) = P + END IF + 190 CONTINUE +* + RETURN +* +* END OF DSTERF +* + END +CUT HERE............ +CAT > DLAE2.F <<'CUT HERE............' + SUBROUTINE DLAE2( A, B, C, RT1, RT2 ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + DOUBLE PRECISION A, B, C, RT1, RT2 +* .. +* +* PURPOSE +* ======= +* +* DLAE2 COMPUTES THE EIGENVALUES OF A 2-BY-2 SYMMETRIC MATRIX +* [ A B ] +* [ B C ]. +* ON RETURN, RT1 IS THE EIGENVALUE OF LARGER ABSOLUTE VALUE, AND RT2 +* IS THE EIGENVALUE OF SMALLER ABSOLUTE VALUE. +* +* ARGUMENTS +* ========= +* +* A (INPUT) DOUBLE PRECISION +* THE (1,1) ENTRY OF THE 2-BY-2 MATRIX. +* +* B (INPUT) DOUBLE PRECISION +* THE (1,2) AND (2,1) ENTRIES OF THE 2-BY-2 MATRIX. +* +* C (INPUT) DOUBLE PRECISION +* THE (2,2) ENTRY OF THE 2-BY-2 MATRIX. +* +* RT1 (OUTPUT) DOUBLE PRECISION +* THE EIGENVALUE OF LARGER ABSOLUTE VALUE. +* +* RT2 (OUTPUT) DOUBLE PRECISION +* THE EIGENVALUE OF SMALLER ABSOLUTE VALUE. +* +* FURTHER DETAILS +* =============== +* +* RT1 IS ACCURATE TO A FEW ULPS BARRING OVER/UNDERFLOW. +* +* RT2 MAY BE INACCURATE IF THERE IS MASSIVE CANCELLATION IN THE +* DETERMINANT A*C-B*B; HIGHER PRECISION OR CORRECTLY ROUNDED OR +* CORRECTLY TRUNCATED ARITHMETIC WOULD BE NEEDED TO COMPUTE RT2 +* ACCURATELY IN ALL CASES. +* +* OVERFLOW IS POSSIBLE ONLY IF RT1 IS WITHIN A FACTOR OF 5 OF OVERFLOW. +* UNDERFLOW IS HARMLESS IF THE INPUT DATA IS 0 OR EXCEEDS +* UNDERFLOW_THRESHOLD / MACHEPS. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) + DOUBLE PRECISION TWO + PARAMETER ( TWO = 2.0D0 ) + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION HALF + PARAMETER ( HALF = 0.5D0 ) +* .. +* .. LOCAL SCALARS .. + DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS, SQRT +* .. +* .. EXECUTABLE STATEMENTS .. +* +* COMPUTE THE EIGENVALUES +* + SM = A + C + DF = A - C + ADF = ABS( DF ) + TB = B + B + AB = ABS( TB ) + IF( ABS( A ).GT.ABS( C ) ) THEN + ACMX = A + ACMN = C + ELSE + ACMX = C + ACMN = A + END IF + IF( ADF.GT.AB ) THEN + RT = ADF*SQRT( ONE+( AB / ADF )**2 ) + ELSE IF( ADF.LT.AB ) THEN + RT = AB*SQRT( ONE+( ADF / AB )**2 ) + ELSE +* +* INCLUDES CASE AB=ADF=0 +* + RT = AB*SQRT( TWO ) + END IF + IF( SM.LT.ZERO ) THEN + RT1 = HALF*( SM-RT ) +* +* ORDER OF EXECUTION IMPORTANT. +* TO GET FULLY ACCURATE SMALLER EIGENVALUE, +* NEXT LINE NEEDS TO BE EXECUTED IN HIGHER PRECISION. +* + RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B + ELSE IF( SM.GT.ZERO ) THEN + RT1 = HALF*( SM+RT ) +* +* ORDER OF EXECUTION IMPORTANT. +* TO GET FULLY ACCURATE SMALLER EIGENVALUE, +* NEXT LINE NEEDS TO BE EXECUTED IN HIGHER PRECISION. +* + RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B + ELSE +* +* INCLUDES CASE RT1 = RT2 = 0 +* + RT1 = HALF*RT + RT2 = -HALF*RT + END IF + RETURN +* +* END OF DLAE2 +* + END +CUT HERE............ +CAT > DSYTRD.F <<'CUT HERE............' + SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* MARCH 31, 1993 +* +* .. SCALAR ARGUMENTS .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ), + $ WORK( * ) +* .. +* +* PURPOSE +* ======= +* +* DSYTRD REDUCES A REAL SYMMETRIC MATRIX A TO REAL SYMMETRIC +* TRIDIAGONAL FORM T BY AN ORTHOGONAL SIMILARITY TRANSFORMATION: +* Q**T * A * Q = T. +* +* ARGUMENTS +* ========= +* +* UPLO (INPUT) CHARACTER*1 +* = 'U': UPPER TRIANGLE OF A IS STORED; +* = 'L': LOWER TRIANGLE OF A IS STORED. +* +* N (INPUT) INTEGER +* THE ORDER OF THE MATRIX A. N >= 0. +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* ON ENTRY, THE SYMMETRIC MATRIX A. IF UPLO = 'U', THE LEADING +* N-BY-N UPPER TRIANGULAR PART OF A CONTAINS THE UPPER +* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY LOWER +* TRIANGULAR PART OF A IS NOT REFERENCED. IF UPLO = 'L', THE +* LEADING N-BY-N LOWER TRIANGULAR PART OF A CONTAINS THE LOWER +* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY UPPER +* TRIANGULAR PART OF A IS NOT REFERENCED. +* ON EXIT, IF UPLO = 'U', THE DIAGONAL AND FIRST SUPERDIAGONAL +* OF A ARE OVERWRITTEN BY THE CORRESPONDING ELEMENTS OF THE +* TRIDIAGONAL MATRIX T, AND THE ELEMENTS ABOVE THE FIRST +* SUPERDIAGONAL, WITH THE ARRAY TAU, REPRESENT THE ORTHOGONAL +* MATRIX Q AS A PRODUCT OF ELEMENTARY REFLECTORS; IF UPLO +* = 'L', THE DIAGONAL AND FIRST SUBDIAGONAL OF A ARE OVER- +* WRITTEN BY THE CORRESPONDING ELEMENTS OF THE TRIDIAGONAL +* MATRIX T, AND THE ELEMENTS BELOW THE FIRST SUBDIAGONAL, WITH +* THE ARRAY TAU, REPRESENT THE ORTHOGONAL MATRIX Q AS A PRODUCT +* OF ELEMENTARY REFLECTORS. SEE FURTHER DETAILS. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N). +* +* D (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T: +* D(I) = A(I,I). +* +* E (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) +* THE OFF-DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T: +* E(I) = A(I,I+1) IF UPLO = 'U', E(I) = A(I+1,I) IF UPLO = 'L'. +* +* TAU (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) +* THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS (SEE FURTHER +* DETAILS). +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK) +* ON EXIT, IF INFO = 0, WORK(1) RETURNS THE OPTIMAL LWORK. +* +* LWORK (INPUT) INTEGER +* THE DIMENSION OF THE ARRAY WORK. LWORK >= 1. +* FOR OPTIMUM PERFORMANCE LWORK >= N*NB, WHERE NB IS THE +* OPTIMAL BLOCKSIZE. +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE +* +* FURTHER DETAILS +* =============== +* +* IF UPLO = 'U', THE MATRIX Q IS REPRESENTED AS A PRODUCT OF ELEMENTARY +* REFLECTORS +* +* Q = H(N-1) . . . H(2) H(1). +* +* EACH H(I) HAS THE FORM +* +* H(I) = I - TAU * V * V' +* +* WHERE TAU IS A REAL SCALAR, AND V IS A REAL VECTOR WITH +* V(I+1:N) = 0 AND V(I) = 1; V(1:I-1) IS STORED ON EXIT IN +* A(1:I-1,I+1), AND TAU IN TAU(I). +* +* IF UPLO = 'L', THE MATRIX Q IS REPRESENTED AS A PRODUCT OF ELEMENTARY +* REFLECTORS +* +* Q = H(1) H(2) . . . H(N-1). +* +* EACH H(I) HAS THE FORM +* +* H(I) = I - TAU * V * V' +* +* WHERE TAU IS A REAL SCALAR, AND V IS A REAL VECTOR WITH +* V(1:I) = 0 AND V(I+1) = 1; V(I+2:N) IS STORED ON EXIT IN A(I+2:N,I), +* AND TAU IN TAU(I). +* +* THE CONTENTS OF A ON EXIT ARE ILLUSTRATED BY THE FOLLOWING EXAMPLES +* WITH N = 5: +* +* IF UPLO = 'U': IF UPLO = 'L': +* +* ( D E V2 V3 V4 ) ( D ) +* ( D E V3 V4 ) ( E D ) +* ( D E V4 ) ( V1 E D ) +* ( D E ) ( V1 V2 E D ) +* ( D ) ( V1 V2 V3 E D ) +* +* WHERE D AND E DENOTE DIAGONAL AND OFF-DIAGONAL ELEMENTS OF T, AND VI +* DENOTES AN ELEMENT OF THE VECTOR DEFINING H(I). +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. LOCAL SCALARS .. + LOGICAL UPPER + INTEGER I, IINFO, IWS, J, KK, LDWORK, NB, NBMIN, NX +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLATRD, DSYR2K, DSYTD2, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 ) THEN + INFO = -9 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRD', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( N.EQ.0 ) THEN + WORK( 1 ) = 1 + RETURN + END IF +* +* DETERMINE THE BLOCK SIZE. +* + NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) + NX = N + IWS = 1 + IF( NB.GT.1 .AND. NB.LT.N ) THEN +* +* DETERMINE WHEN TO CROSS OVER FROM BLOCKED TO UNBLOCKED CODE +* (LAST BLOCK IS ALWAYS HANDLED BY UNBLOCKED CODE). +* + NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) ) + IF( NX.LT.N ) THEN +* +* DETERMINE IF WORKSPACE IS LARGE ENOUGH FOR BLOCKED CODE. +* + LDWORK = N + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN +* +* NOT ENOUGH WORKSPACE TO USE OPTIMAL NB: DETERMINE THE +* MINIMUM VALUE OF NB, AND REDUCE NB OR FORCE USE OF +* UNBLOCKED CODE BY SETTING NX = N. +* + NB = LWORK / LDWORK + NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 ) + IF( NB.LT.NBMIN ) + $ NX = N + END IF + ELSE + NX = N + END IF + ELSE + NB = 1 + END IF +* + IF( UPPER ) THEN +* +* REDUCE THE UPPER TRIANGLE OF A. +* COLUMNS 1:KK ARE HANDLED BY THE UNBLOCKED METHOD. +* + KK = N - ( ( N-NX+NB-1 ) / NB )*NB + DO 20 I = N - NB + 1, KK + 1, -NB +* +* REDUCE COLUMNS I:I+NB-1 TO TRIDIAGONAL FORM AND FORM THE +* MATRIX W WHICH IS NEEDED TO UPDATE THE UNREDUCED PART OF +* THE MATRIX +* + CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK, + $ LDWORK ) +* +* UPDATE THE UNREDUCED SUBMATRIX A(1:I-1,1:I-1), USING AN +* UPDATE OF THE FORM: A := A - V*W' - W*V' +* + CALL DSYR2K( UPLO, 'NO TRANSPOSE', I-1, NB, -ONE, A( 1, I ), + $ LDA, WORK, LDWORK, ONE, A, LDA ) +* +* COPY SUPERDIAGONAL ELEMENTS BACK INTO A, AND DIAGONAL +* ELEMENTS INTO D +* + DO 10 J = I, I + NB - 1 + A( J-1, J ) = E( J-1 ) + D( J ) = A( J, J ) + 10 CONTINUE + 20 CONTINUE +* +* USE UNBLOCKED CODE TO REDUCE THE LAST OR ONLY BLOCK +* + CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO ) + ELSE +* +* REDUCE THE LOWER TRIANGLE OF A +* + DO 40 I = 1, N - NX, NB +* +* REDUCE COLUMNS I:I+NB-1 TO TRIDIAGONAL FORM AND FORM THE +* MATRIX W WHICH IS NEEDED TO UPDATE THE UNREDUCED PART OF +* THE MATRIX +* + CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ), + $ TAU( I ), WORK, LDWORK ) +* +* UPDATE THE UNREDUCED SUBMATRIX A(I+IB:N,I+IB:N), USING +* AN UPDATE OF THE FORM: A := A - V*W' - W*V' +* + CALL DSYR2K( UPLO, 'NO TRANSPOSE', N-I-NB+1, NB, -ONE, + $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE, + $ A( I+NB, I+NB ), LDA ) +* +* COPY SUBDIAGONAL ELEMENTS BACK INTO A, AND DIAGONAL +* ELEMENTS INTO D +* + DO 30 J = I, I + NB - 1 + A( J+1, J ) = E( J ) + D( J ) = A( J, J ) + 30 CONTINUE + 40 CONTINUE +* +* USE UNBLOCKED CODE TO REDUCE THE LAST OR ONLY BLOCK +* + CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ), + $ TAU( I ), IINFO ) + END IF +* + WORK( 1 ) = IWS + RETURN +* +* END OF DSYTRD +* + END +CUT HERE............ +CAT > DSYTD2.F <<'CUT HERE............' + SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ) +* .. +* +* PURPOSE +* ======= +* +* DSYTD2 REDUCES A REAL SYMMETRIC MATRIX A TO SYMMETRIC TRIDIAGONAL +* FORM T BY AN ORTHOGONAL SIMILARITY TRANSFORMATION: Q' * A * Q = T. +* +* ARGUMENTS +* ========= +* +* UPLO (INPUT) CHARACTER*1 +* SPECIFIES WHETHER THE UPPER OR LOWER TRIANGULAR PART OF THE +* SYMMETRIC MATRIX A IS STORED: +* = 'U': UPPER TRIANGULAR +* = 'L': LOWER TRIANGULAR +* +* N (INPUT) INTEGER +* THE ORDER OF THE MATRIX A. N >= 0. +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* ON ENTRY, THE SYMMETRIC MATRIX A. IF UPLO = 'U', THE LEADING +* N-BY-N UPPER TRIANGULAR PART OF A CONTAINS THE UPPER +* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY LOWER +* TRIANGULAR PART OF A IS NOT REFERENCED. IF UPLO = 'L', THE +* LEADING N-BY-N LOWER TRIANGULAR PART OF A CONTAINS THE LOWER +* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY UPPER +* TRIANGULAR PART OF A IS NOT REFERENCED. +* ON EXIT, IF UPLO = 'U', THE DIAGONAL AND FIRST SUPERDIAGONAL +* OF A ARE OVERWRITTEN BY THE CORRESPONDING ELEMENTS OF THE +* TRIDIAGONAL MATRIX T, AND THE ELEMENTS ABOVE THE FIRST +* SUPERDIAGONAL, WITH THE ARRAY TAU, REPRESENT THE ORTHOGONAL +* MATRIX Q AS A PRODUCT OF ELEMENTARY REFLECTORS; IF UPLO +* = 'L', THE DIAGONAL AND FIRST SUBDIAGONAL OF A ARE OVER- +* WRITTEN BY THE CORRESPONDING ELEMENTS OF THE TRIDIAGONAL +* MATRIX T, AND THE ELEMENTS BELOW THE FIRST SUBDIAGONAL, WITH +* THE ARRAY TAU, REPRESENT THE ORTHOGONAL MATRIX Q AS A PRODUCT +* OF ELEMENTARY REFLECTORS. SEE FURTHER DETAILS. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N). +* +* D (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N) +* THE DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T: +* D(I) = A(I,I). +* +* E (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) +* THE OFF-DIAGONAL ELEMENTS OF THE TRIDIAGONAL MATRIX T: +* E(I) = A(I,I+1) IF UPLO = 'U', E(I) = A(I+1,I) IF UPLO = 'L'. +* +* TAU (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) +* THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS (SEE FURTHER +* DETAILS). +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE. +* +* FURTHER DETAILS +* =============== +* +* IF UPLO = 'U', THE MATRIX Q IS REPRESENTED AS A PRODUCT OF ELEMENTARY +* REFLECTORS +* +* Q = H(N-1) . . . H(2) H(1). +* +* EACH H(I) HAS THE FORM +* +* H(I) = I - TAU * V * V' +* +* WHERE TAU IS A REAL SCALAR, AND V IS A REAL VECTOR WITH +* V(I+1:N) = 0 AND V(I) = 1; V(1:I-1) IS STORED ON EXIT IN +* A(1:I-1,I+1), AND TAU IN TAU(I). +* +* IF UPLO = 'L', THE MATRIX Q IS REPRESENTED AS A PRODUCT OF ELEMENTARY +* REFLECTORS +* +* Q = H(1) H(2) . . . H(N-1). +* +* EACH H(I) HAS THE FORM +* +* H(I) = I - TAU * V * V' +* +* WHERE TAU IS A REAL SCALAR, AND V IS A REAL VECTOR WITH +* V(1:I) = 0 AND V(I+1) = 1; V(I+2:N) IS STORED ON EXIT IN A(I+2:N,I), +* AND TAU IN TAU(I). +* +* THE CONTENTS OF A ON EXIT ARE ILLUSTRATED BY THE FOLLOWING EXAMPLES +* WITH N = 5: +* +* IF UPLO = 'U': IF UPLO = 'L': +* +* ( D E V2 V3 V4 ) ( D ) +* ( D E V3 V4 ) ( E D ) +* ( D E V4 ) ( V1 E D ) +* ( D E ) ( V1 V2 E D ) +* ( D ) ( V1 V2 V3 E D ) +* +* WHERE D AND E DENOTE DIAGONAL AND OFF-DIAGONAL ELEMENTS OF T, AND VI +* DENOTES AN ELEMENT OF THE VECTOR DEFINING H(I). +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE, ZERO, HALF + PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, + $ HALF = 1.0D0 / 2.0D0 ) +* .. +* .. LOCAL SCALARS .. + LOGICAL UPPER + INTEGER I + DOUBLE PRECISION ALPHA, TAUI +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DAXPY, DLARFG, DSYMV, DSYR2, XERBLA +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTD2', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( N.LE.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* REDUCE THE UPPER TRIANGLE OF A +* + DO 10 I = N - 1, 1, -1 +* +* GENERATE ELEMENTARY REFLECTOR H(I) = I - TAU * V * V' +* TO ANNIHILATE A(1:I-1,I+1) +* + CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI ) + E( I ) = A( I, I+1 ) +* + IF( TAUI.NE.ZERO ) THEN +* +* APPLY H(I) FROM BOTH SIDES TO A(1:I,1:I) +* + A( I, I+1 ) = ONE +* +* COMPUTE X := TAU * A * V STORING X IN TAU(1:I) +* + CALL DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO, + $ TAU, 1 ) +* +* COMPUTE W := X - 1/2 * TAU * (X'*V) * V +* + ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 ) + CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 ) +* +* APPLY THE TRANSFORMATION AS A RANK-2 UPDATE: +* A := A - V * W' - W * V' +* + CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A, + $ LDA ) +* + A( I, I+1 ) = E( I ) + END IF + D( I+1 ) = A( I+1, I+1 ) + TAU( I ) = TAUI + 10 CONTINUE + D( 1 ) = A( 1, 1 ) + ELSE +* +* REDUCE THE LOWER TRIANGLE OF A +* + DO 20 I = 1, N - 1 +* +* GENERATE ELEMENTARY REFLECTOR H(I) = I - TAU * V * V' +* TO ANNIHILATE A(I+2:N,I) +* + CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, + $ TAUI ) + E( I ) = A( I+1, I ) +* + IF( TAUI.NE.ZERO ) THEN +* +* APPLY H(I) FROM BOTH SIDES TO A(I+1:N,I+1:N) +* + A( I+1, I ) = ONE +* +* COMPUTE X := TAU * A * V STORING Y IN TAU(I:N-1) +* + CALL DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA, + $ A( I+1, I ), 1, ZERO, TAU( I ), 1 ) +* +* COMPUTE W := X - 1/2 * TAU * (X'*V) * V +* + ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ), + $ 1 ) + CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 ) +* +* APPLY THE TRANSFORMATION AS A RANK-2 UPDATE: +* A := A - V * W' - W * V' +* + CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1, + $ A( I+1, I+1 ), LDA ) +* + A( I+1, I ) = E( I ) + END IF + D( I ) = A( I, I ) + TAU( I ) = TAUI + 20 CONTINUE + D( N ) = A( N, N ) + END IF +* + RETURN +* +* END OF DSYTD2 +* + END +CUT HERE............ +CAT > DLATRD.F <<'CUT HERE............' + SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + CHARACTER UPLO + INTEGER LDA, LDW, N, NB +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) +* .. +* +* PURPOSE +* ======= +* +* DLATRD REDUCES NB ROWS AND COLUMNS OF A REAL SYMMETRIC MATRIX A TO +* SYMMETRIC TRIDIAGONAL FORM BY AN ORTHOGONAL SIMILARITY +* TRANSFORMATION Q' * A * Q, AND RETURNS THE MATRICES V AND W WHICH ARE +* NEEDED TO APPLY THE TRANSFORMATION TO THE UNREDUCED PART OF A. +* +* IF UPLO = 'U', DLATRD REDUCES THE LAST NB ROWS AND COLUMNS OF A +* MATRIX, OF WHICH THE UPPER TRIANGLE IS SUPPLIED; +* IF UPLO = 'L', DLATRD REDUCES THE FIRST NB ROWS AND COLUMNS OF A +* MATRIX, OF WHICH THE LOWER TRIANGLE IS SUPPLIED. +* +* THIS IS AN AUXILIARY ROUTINE CALLED BY DSYTRD. +* +* ARGUMENTS +* ========= +* +* UPLO (INPUT) CHARACTER +* SPECIFIES WHETHER THE UPPER OR LOWER TRIANGULAR PART OF THE +* SYMMETRIC MATRIX A IS STORED: +* = 'U': UPPER TRIANGULAR +* = 'L': LOWER TRIANGULAR +* +* N (INPUT) INTEGER +* THE ORDER OF THE MATRIX A. +* +* NB (INPUT) INTEGER +* THE NUMBER OF ROWS AND COLUMNS TO BE REDUCED. +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* ON ENTRY, THE SYMMETRIC MATRIX A. IF UPLO = 'U', THE LEADING +* N-BY-N UPPER TRIANGULAR PART OF A CONTAINS THE UPPER +* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY LOWER +* TRIANGULAR PART OF A IS NOT REFERENCED. IF UPLO = 'L', THE +* LEADING N-BY-N LOWER TRIANGULAR PART OF A CONTAINS THE LOWER +* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY UPPER +* TRIANGULAR PART OF A IS NOT REFERENCED. +* ON EXIT: +* IF UPLO = 'U', THE LAST NB COLUMNS HAVE BEEN REDUCED TO +* TRIDIAGONAL FORM, WITH THE DIAGONAL ELEMENTS OVERWRITING +* THE DIAGONAL ELEMENTS OF A; THE ELEMENTS ABOVE THE DIAGONAL +* WITH THE ARRAY TAU, REPRESENT THE ORTHOGONAL MATRIX Q AS A +* PRODUCT OF ELEMENTARY REFLECTORS; +* IF UPLO = 'L', THE FIRST NB COLUMNS HAVE BEEN REDUCED TO +* TRIDIAGONAL FORM, WITH THE DIAGONAL ELEMENTS OVERWRITING +* THE DIAGONAL ELEMENTS OF A; THE ELEMENTS BELOW THE DIAGONAL +* WITH THE ARRAY TAU, REPRESENT THE ORTHOGONAL MATRIX Q AS A +* PRODUCT OF ELEMENTARY REFLECTORS. +* SEE FURTHER DETAILS. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. LDA >= (1,N). +* +* E (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) +* IF UPLO = 'U', E(N-NB:N-1) CONTAINS THE SUPERDIAGONAL +* ELEMENTS OF THE LAST NB COLUMNS OF THE REDUCED MATRIX; +* IF UPLO = 'L', E(1:NB) CONTAINS THE SUBDIAGONAL ELEMENTS OF +* THE FIRST NB COLUMNS OF THE REDUCED MATRIX. +* +* TAU (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (N-1) +* THE SCALAR FACTORS OF THE ELEMENTARY REFLECTORS, STORED IN +* TAU(N-NB:N-1) IF UPLO = 'U', AND IN TAU(1:NB) IF UPLO = 'L'. +* SEE FURTHER DETAILS. +* +* W (OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDW,NB) +* THE N-BY-NB MATRIX W REQUIRED TO UPDATE THE UNREDUCED PART +* OF A. +* +* LDW (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY W. LDW >= MAX(1,N). +* +* FURTHER DETAILS +* =============== +* +* IF UPLO = 'U', THE MATRIX Q IS REPRESENTED AS A PRODUCT OF ELEMENTARY +* REFLECTORS +* +* Q = H(N) H(N-1) . . . H(N-NB+1). +* +* EACH H(I) HAS THE FORM +* +* H(I) = I - TAU * V * V' +* +* WHERE TAU IS A REAL SCALAR, AND V IS A REAL VECTOR WITH +* V(I:N) = 0 AND V(I-1) = 1; V(1:I-1) IS STORED ON EXIT IN A(1:I-1,I), +* AND TAU IN TAU(I-1). +* +* IF UPLO = 'L', THE MATRIX Q IS REPRESENTED AS A PRODUCT OF ELEMENTARY +* REFLECTORS +* +* Q = H(1) H(2) . . . H(NB). +* +* EACH H(I) HAS THE FORM +* +* H(I) = I - TAU * V * V' +* +* WHERE TAU IS A REAL SCALAR, AND V IS A REAL VECTOR WITH +* V(1:I) = 0 AND V(I+1) = 1; V(I+1:N) IS STORED ON EXIT IN A(I+1:N,I), +* AND TAU IN TAU(I). +* +* THE ELEMENTS OF THE VECTORS V TOGETHER FORM THE N-BY-NB MATRIX V +* WHICH IS NEEDED, WITH W, TO APPLY THE TRANSFORMATION TO THE UNREDUCED +* PART OF THE MATRIX, USING A SYMMETRIC RANK-2K UPDATE OF THE FORM: +* A := A - V*W' - W*V'. +* +* THE CONTENTS OF A ON EXIT ARE ILLUSTRATED BY THE FOLLOWING EXAMPLES +* WITH N = 5 AND NB = 2: +* +* IF UPLO = 'U': IF UPLO = 'L': +* +* ( A A A V4 V5 ) ( D ) +* ( A A V4 V5 ) ( 1 D ) +* ( A 1 V5 ) ( V1 1 A ) +* ( D 1 ) ( V1 V2 A A ) +* ( D ) ( V1 V2 A A A ) +* +* WHERE D DENOTES A DIAGONAL ELEMENT OF THE REDUCED MATRIX, A DENOTES +* AN ELEMENT OF THE ORIGINAL MATRIX THAT IS UNCHANGED, AND VI DENOTES +* AN ELEMENT OF THE VECTOR DEFINING H(I). +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO, ONE, HALF + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER I, IW + DOUBLE PRECISION ALPHA +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DAXPY, DGEMV, DLARFG, DSCAL, DSYMV +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MIN +* .. +* .. EXECUTABLE STATEMENTS .. +* +* QUICK RETURN IF POSSIBLE +* + IF( N.LE.0 ) + $ RETURN +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* REDUCE LAST NB COLUMNS OF UPPER TRIANGLE +* + DO 10 I = N, N - NB + 1, -1 + IW = I - N + NB + IF( I.LT.N ) THEN +* +* UPDATE A(1:I,I) +* + CALL DGEMV( 'NO TRANSPOSE', I, N-I, -ONE, A( 1, I+1 ), + $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 ) + CALL DGEMV( 'NO TRANSPOSE', I, N-I, -ONE, W( 1, IW+1 ), + $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 ) + END IF + IF( I.GT.1 ) THEN +* +* GENERATE ELEMENTARY REFLECTOR H(I) TO ANNIHILATE +* A(1:I-2,I) +* + CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) ) + E( I-1 ) = A( I-1, I ) + A( I-1, I ) = ONE +* +* COMPUTE W(1:I-1,I) +* + CALL DSYMV( 'UPPER', I-1, ONE, A, LDA, A( 1, I ), 1, + $ ZERO, W( 1, IW ), 1 ) + IF( I.LT.N ) THEN + CALL DGEMV( 'TRANSPOSE', I-1, N-I, ONE, W( 1, IW+1 ), + $ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) + CALL DGEMV( 'NO TRANSPOSE', I-1, N-I, -ONE, + $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE, + $ W( 1, IW ), 1 ) + CALL DGEMV( 'TRANSPOSE', I-1, N-I, ONE, A( 1, I+1 ), + $ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 ) + CALL DGEMV( 'NO TRANSPOSE', I-1, N-I, -ONE, + $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE, + $ W( 1, IW ), 1 ) + END IF + CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 ) + ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1, + $ A( 1, I ), 1 ) + CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 ) + END IF +* + 10 CONTINUE + ELSE +* +* REDUCE FIRST NB COLUMNS OF LOWER TRIANGLE +* + DO 20 I = 1, NB +* +* UPDATE A(I:N,I) +* + CALL DGEMV( 'NO TRANSPOSE', N-I+1, I-1, -ONE, A( I, 1 ), + $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 ) + CALL DGEMV( 'NO TRANSPOSE', N-I+1, I-1, -ONE, W( I, 1 ), + $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 ) + IF( I.LT.N ) THEN +* +* GENERATE ELEMENTARY REFLECTOR H(I) TO ANNIHILATE +* A(I+2:N,I) +* + CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1, + $ TAU( I ) ) + E( I ) = A( I+1, I ) + A( I+1, I ) = ONE +* +* COMPUTE W(I+1:N,I) +* + CALL DSYMV( 'LOWER', N-I, ONE, A( I+1, I+1 ), LDA, + $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 ) + CALL DGEMV( 'TRANSPOSE', N-I, I-1, ONE, W( I+1, 1 ), LDW, + $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) + CALL DGEMV( 'NO TRANSPOSE', N-I, I-1, -ONE, A( I+1, 1 ), + $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) + CALL DGEMV( 'TRANSPOSE', N-I, I-1, ONE, A( I+1, 1 ), LDA, + $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 ) + CALL DGEMV( 'NO TRANSPOSE', N-I, I-1, -ONE, W( I+1, 1 ), + $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 ) + CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 ) + ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1, + $ A( I+1, I ), 1 ) + CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 ) + END IF +* + 20 CONTINUE + END IF +* + RETURN +* +* END OF DLATRD +* + END +CUT HERE............ +CAT > DLARFG.F <<'CUT HERE............' + SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* FEBRUARY 29, 1992 +* +* .. SCALAR ARGUMENTS .. + INTEGER INCX, N + DOUBLE PRECISION ALPHA, TAU +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION X( * ) +* .. +* +* PURPOSE +* ======= +* +* DLARFG GENERATES A REAL ELEMENTARY REFLECTOR H OF ORDER N, SUCH +* THAT +* +* H * ( ALPHA ) = ( BETA ), H' * H = I. +* ( X ) ( 0 ) +* +* WHERE ALPHA AND BETA ARE SCALARS, AND X IS AN (N-1)-ELEMENT REAL +* VECTOR. H IS REPRESENTED IN THE FORM +* +* H = I - TAU * ( 1 ) * ( 1 V' ) , +* ( V ) +* +* WHERE TAU IS A REAL SCALAR AND V IS A REAL (N-1)-ELEMENT +* VECTOR. +* +* IF THE ELEMENTS OF X ARE ALL ZERO, THEN TAU = 0 AND H IS TAKEN TO BE +* THE UNIT MATRIX. +* +* OTHERWISE 1 <= TAU <= 2. +* +* ARGUMENTS +* ========= +* +* N (INPUT) INTEGER +* THE ORDER OF THE ELEMENTARY REFLECTOR. +* +* ALPHA (INPUT/OUTPUT) DOUBLE PRECISION +* ON ENTRY, THE VALUE ALPHA. +* ON EXIT, IT IS OVERWRITTEN WITH THE VALUE BETA. +* +* X (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION +* (1+(N-2)*ABS(INCX)) +* ON ENTRY, THE VECTOR X. +* ON EXIT, IT IS OVERWRITTEN WITH THE VECTOR V. +* +* INCX (INPUT) INTEGER +* THE INCREMENT BETWEEN ELEMENTS OF X. INCX <> 0. +* +* TAU (OUTPUT) DOUBLE PRECISION +* THE VALUE TAU. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER J, KNT + DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM +* .. +* .. EXTERNAL FUNCTIONS .. + DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 + EXTERNAL DLAMCH, DLAPY2, DNRM2 +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS, SIGN +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DSCAL +* .. +* .. EXECUTABLE STATEMENTS .. +* + IF( N.LE.1 ) THEN + TAU = ZERO + RETURN + END IF +* + XNORM = DNRM2( N-1, X, INCX ) +* + IF( XNORM.EQ.ZERO ) THEN +* +* H = I +* + TAU = ZERO + ELSE +* +* GENERAL CASE +* + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + SAFMIN = DLAMCH( 'S' ) + IF( ABS( BETA ).LT.SAFMIN ) THEN +* +* XNORM, BETA MAY BE INACCURATE; SCALE X AND RECOMPUTE THEM +* + RSAFMN = ONE / SAFMIN + KNT = 0 + 10 CONTINUE + KNT = KNT + 1 + CALL DSCAL( N-1, RSAFMN, X, INCX ) + BETA = BETA*RSAFMN + ALPHA = ALPHA*RSAFMN + IF( ABS( BETA ).LT.SAFMIN ) + $ GO TO 10 +* +* NEW BETA IS AT MOST 1, AT LEAST SAFMIN +* + XNORM = DNRM2( N-1, X, INCX ) + BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) + TAU = ( BETA-ALPHA ) / BETA + CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) +* +* IF ALPHA IS SUBNORMAL, IT MAY LOSE RELATIVE ACCURACY +* + ALPHA = BETA + DO 20 J = 1, KNT + ALPHA = ALPHA*SAFMIN + 20 CONTINUE + ELSE + TAU = ( BETA-ALPHA ) / BETA + CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) + ALPHA = BETA + END IF + END IF +* + RETURN +* +* END OF DLARFG +* + END +CUT HERE............ +CAT > DLAMCH.F <<'CUT HERE............' + DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + CHARACTER CMACH +* .. +* +* PURPOSE +* ======= +* +* DLAMCH DETERMINES DOUBLE PRECISION MACHINE PARAMETERS. +* +* ARGUMENTS +* ========= +* +* CMACH (INPUT) CHARACTER*1 +* SPECIFIES THE VALUE TO BE RETURNED BY DLAMCH: +* = 'E' OR 'E', DLAMCH := EPS +* = 'S' OR 'S , DLAMCH := SFMIN +* = 'B' OR 'B', DLAMCH := BASE +* = 'P' OR 'P', DLAMCH := EPS*BASE +* = 'N' OR 'N', DLAMCH := T +* = 'R' OR 'R', DLAMCH := RND +* = 'M' OR 'M', DLAMCH := EMIN +* = 'U' OR 'U', DLAMCH := RMIN +* = 'L' OR 'L', DLAMCH := EMAX +* = 'O' OR 'O', DLAMCH := RMAX +* +* WHERE +* +* EPS = RELATIVE MACHINE PRECISION +* SFMIN = SAFE MINIMUM, SUCH THAT 1/SFMIN DOES NOT OVERFLOW +* BASE = BASE OF THE MACHINE +* PREC = EPS*BASE +* T = NUMBER OF (BASE) DIGITS IN THE MANTISSA +* RND = 1.0 WHEN ROUNDING OCCURS IN ADDITION, 0.0 OTHERWISE +* EMIN = MINIMUM EXPONENT BEFORE (GRADUAL) UNDERFLOW +* RMIN = UNDERFLOW THRESHOLD - BASE**(EMIN-1) +* EMAX = LARGEST EXPONENT BEFORE OVERFLOW +* RMAX = OVERFLOW THRESHOLD - (BASE**EMAX)*(1-EPS) +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. LOCAL SCALARS .. + LOGICAL FIRST, LRND + INTEGER BETA, IMAX, IMIN, IT + DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, + $ RND, SFMIN, SMALL, T +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLAMC2 +* .. +* .. SAVE STATEMENT .. + SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, + $ EMAX, RMAX, PREC +* .. +* .. DATA STATEMENTS .. + DATA FIRST / .TRUE. / +* .. +* .. EXECUTABLE STATEMENTS .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) + BASE = BETA + T = IT + IF( LRND ) THEN + RND = ONE + EPS = ( BASE**( 1-IT ) ) / 2 + ELSE + RND = ZERO + EPS = BASE**( 1-IT ) + END IF + PREC = EPS*BASE + EMIN = IMIN + EMAX = IMAX + SFMIN = RMIN + SMALL = ONE / RMAX + IF( SMALL.GE.SFMIN ) THEN +* +* USE SMALL PLUS A BIT, TO AVOID THE POSSIBILITY OF ROUNDING +* CAUSING OVERFLOW WHEN COMPUTING 1/SFMIN. +* + SFMIN = SMALL*( ONE+EPS ) + END IF + END IF +* + IF( LSAME( CMACH, 'E' ) ) THEN + RMACH = EPS + ELSE IF( LSAME( CMACH, 'S' ) ) THEN + RMACH = SFMIN + ELSE IF( LSAME( CMACH, 'B' ) ) THEN + RMACH = BASE + ELSE IF( LSAME( CMACH, 'P' ) ) THEN + RMACH = PREC + ELSE IF( LSAME( CMACH, 'N' ) ) THEN + RMACH = T + ELSE IF( LSAME( CMACH, 'R' ) ) THEN + RMACH = RND + ELSE IF( LSAME( CMACH, 'M' ) ) THEN + RMACH = EMIN + ELSE IF( LSAME( CMACH, 'U' ) ) THEN + RMACH = RMIN + ELSE IF( LSAME( CMACH, 'L' ) ) THEN + RMACH = EMAX + ELSE IF( LSAME( CMACH, 'O' ) ) THEN + RMACH = RMAX + END IF +* + DLAMCH = RMACH + RETURN +* +* END OF DLAMCH +* + END +* +************************************************************************ +* + SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + LOGICAL IEEE1, RND + INTEGER BETA, T +* .. +* +* PURPOSE +* ======= +* +* DLAMC1 DETERMINES THE MACHINE PARAMETERS GIVEN BY BETA, T, RND, AND +* IEEE1. +* +* ARGUMENTS +* ========= +* +* BETA (OUTPUT) INTEGER +* THE BASE OF THE MACHINE. +* +* T (OUTPUT) INTEGER +* THE NUMBER OF ( BETA ) DIGITS IN THE MANTISSA. +* +* RND (OUTPUT) LOGICAL +* SPECIFIES WHETHER PROPER ROUNDING ( RND = .TRUE. ) OR +* CHOPPING ( RND = .FALSE. ) OCCURS IN ADDITION. THIS MAY NOT +* BE A RELIABLE GUIDE TO THE WAY IN WHICH THE MACHINE PERFORMS +* ITS ARITHMETIC. +* +* IEEE1 (OUTPUT) LOGICAL +* SPECIFIES WHETHER ROUNDING APPEARS TO BE DONE IN THE IEEE +* 'ROUND TO NEAREST' STYLE. +* +* FURTHER DETAILS +* =============== +* +* THE ROUTINE IS BASED ON THE ROUTINE ENVRON BY MALCOLM AND +* INCORPORATES SUGGESTIONS BY GENTLEMAN AND MAROVICH. SEE +* +* MALCOLM M. A. (1972) ALGORITHMS TO REVEAL PROPERTIES OF +* FLOATING-POINT ARITHMETIC. COMMS. OF THE ACM, 15, 949-951. +* +* GENTLEMAN W. M. AND MAROVICH S. B. (1974) MORE ON ALGORITHMS +* THAT REVEAL PROPERTIES OF FLOATING POINT ARITHMETIC UNITS. +* COMMS. OF THE ACM, 17, 276-277. +* +* ===================================================================== +* +* .. LOCAL SCALARS .. + LOGICAL FIRST, LIEEE1, LRND + INTEGER LBETA, LT + DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 +* .. +* .. EXTERNAL FUNCTIONS .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. SAVE STATEMENT .. + SAVE FIRST, LIEEE1, LBETA, LRND, LT +* .. +* .. DATA STATEMENTS .. + DATA FIRST / .TRUE. / +* .. +* .. EXECUTABLE STATEMENTS .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + ONE = 1 +* +* LBETA, LIEEE1, LT AND LRND ARE THE LOCAL VALUES OF BETA, +* IEEE1, T AND RND. +* +* THROUGHOUT THIS ROUTINE WE USE THE FUNCTION DLAMC3 TO ENSURE +* THAT RELEVANT VALUES ARE STORED AND NOT HELD IN REGISTERS, OR +* ARE NOT AFFECTED BY OPTIMIZERS. +* +* COMPUTE A = 2.0**M WITH THE SMALLEST POSITIVE INTEGER M SUCH +* THAT +* +* FL( A + 1.0 ) = A. +* + A = 1 + C = 1 +* +*+ WHILE( C.EQ.ONE )LOOP + 10 CONTINUE + IF( C.EQ.ONE ) THEN + A = 2*A + C = DLAMC3( A, ONE ) + C = DLAMC3( C, -A ) + GO TO 10 + END IF +*+ END WHILE +* +* NOW COMPUTE B = 2.0**M WITH THE SMALLEST POSITIVE INTEGER M +* SUCH THAT +* +* FL( A + B ) .GT. A. +* + B = 1 + C = DLAMC3( A, B ) +* +*+ WHILE( C.EQ.A )LOOP + 20 CONTINUE + IF( C.EQ.A ) THEN + B = 2*B + C = DLAMC3( A, B ) + GO TO 20 + END IF +*+ END WHILE +* +* NOW COMPUTE THE BASE. A AND C ARE NEIGHBOURING FLOATING POINT +* NUMBERS IN THE INTERVAL ( BETA**T, BETA**( T + 1 ) ) AND SO +* THEIR DIFFERENCE IS BETA. ADDING 0.25 TO C IS TO ENSURE THAT IT +* IS TRUNCATED TO BETA AND NOT ( BETA - 1 ). +* + QTR = ONE / 4 + SAVEC = C + C = DLAMC3( C, -A ) + LBETA = C + QTR +* +* NOW DETERMINE WHETHER ROUNDING OR CHOPPING OCCURS, BY ADDING A +* BIT LESS THAN BETA/2 AND A BIT MORE THAN BETA/2 TO A. +* + B = LBETA + F = DLAMC3( B / 2, -B / 100 ) + C = DLAMC3( F, A ) + IF( C.EQ.A ) THEN + LRND = .TRUE. + ELSE + LRND = .FALSE. + END IF + F = DLAMC3( B / 2, B / 100 ) + C = DLAMC3( F, A ) + IF( ( LRND ) .AND. ( C.EQ.A ) ) + $ LRND = .FALSE. +* +* TRY AND DECIDE WHETHER ROUNDING IS DONE IN THE IEEE 'ROUND TO +* NEAREST' STYLE. B/2 IS HALF A UNIT IN THE LAST PLACE OF THE TWO +* NUMBERS A AND SAVEC. FURTHERMORE, A IS EVEN, I.E. HAS LAST BIT +* ZERO, AND SAVEC IS ODD. THUS ADDING B/2 TO A SHOULD NOT CHANGE +* A, BUT ADDING B/2 TO SAVEC SHOULD CHANGE SAVEC. +* + T1 = DLAMC3( B / 2, A ) + T2 = DLAMC3( B / 2, SAVEC ) + LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND +* +* NOW FIND THE MANTISSA, T. IT SHOULD BE THE INTEGER PART OF +* LOG TO THE BASE BETA OF A, HOWEVER IT IS SAFER TO DETERMINE T +* BY POWERING. SO WE FIND T AS THE SMALLEST POSITIVE INTEGER FOR +* WHICH +* +* FL( BETA**T + 1.0 ) = 1.0. +* + LT = 0 + A = 1 + C = 1 +* +*+ WHILE( C.EQ.ONE )LOOP + 30 CONTINUE + IF( C.EQ.ONE ) THEN + LT = LT + 1 + A = A*LBETA + C = DLAMC3( A, ONE ) + C = DLAMC3( C, -A ) + GO TO 30 + END IF +*+ END WHILE +* + END IF +* + BETA = LBETA + T = LT + RND = LRND + IEEE1 = LIEEE1 + RETURN +* +* END OF DLAMC1 +* + END +* +************************************************************************ +* + SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + LOGICAL RND + INTEGER BETA, EMAX, EMIN, T + DOUBLE PRECISION EPS, RMAX, RMIN +* .. +* +* PURPOSE +* ======= +* +* DLAMC2 DETERMINES THE MACHINE PARAMETERS SPECIFIED IN ITS ARGUMENT +* LIST. +* +* ARGUMENTS +* ========= +* +* BETA (OUTPUT) INTEGER +* THE BASE OF THE MACHINE. +* +* T (OUTPUT) INTEGER +* THE NUMBER OF ( BETA ) DIGITS IN THE MANTISSA. +* +* RND (OUTPUT) LOGICAL +* SPECIFIES WHETHER PROPER ROUNDING ( RND = .TRUE. ) OR +* CHOPPING ( RND = .FALSE. ) OCCURS IN ADDITION. THIS MAY NOT +* BE A RELIABLE GUIDE TO THE WAY IN WHICH THE MACHINE PERFORMS +* ITS ARITHMETIC. +* +* EPS (OUTPUT) DOUBLE PRECISION +* THE SMALLEST POSITIVE NUMBER SUCH THAT +* +* FL( 1.0 - EPS ) .LT. 1.0, +* +* WHERE FL DENOTES THE COMPUTED VALUE. +* +* EMIN (OUTPUT) INTEGER +* THE MINIMUM EXPONENT BEFORE (GRADUAL) UNDERFLOW OCCURS. +* +* RMIN (OUTPUT) DOUBLE PRECISION +* THE SMALLEST NORMALIZED NUMBER FOR THE MACHINE, GIVEN BY +* BASE**( EMIN - 1 ), WHERE BASE IS THE FLOATING POINT VALUE +* OF BETA. +* +* EMAX (OUTPUT) INTEGER +* THE MAXIMUM EXPONENT BEFORE OVERFLOW OCCURS. +* +* RMAX (OUTPUT) DOUBLE PRECISION +* THE LARGEST POSITIVE NUMBER FOR THE MACHINE, GIVEN BY +* BASE**EMAX * ( 1 - EPS ), WHERE BASE IS THE FLOATING POINT +* VALUE OF BETA. +* +* FURTHER DETAILS +* =============== +* +* THE COMPUTATION OF EPS IS BASED ON A ROUTINE PARANOIA BY +* W. KAHAN OF THE UNIVERSITY OF CALIFORNIA AT BERKELEY. +* +* ===================================================================== +* +* .. LOCAL SCALARS .. + LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND + INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, + $ NGNMIN, NGPMIN + DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, + $ SIXTH, SMALL, THIRD, TWO, ZERO +* .. +* .. EXTERNAL FUNCTIONS .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLAMC1, DLAMC4, DLAMC5 +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS, MAX, MIN +* .. +* .. SAVE STATEMENT .. + SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, + $ LRMIN, LT +* .. +* .. DATA STATEMENTS .. + DATA FIRST / .TRUE. / , IWARN / .FALSE. / +* .. +* .. EXECUTABLE STATEMENTS .. +* + IF( FIRST ) THEN + FIRST = .FALSE. + ZERO = 0 + ONE = 1 + TWO = 2 +* +* LBETA, LT, LRND, LEPS, LEMIN AND LRMIN ARE THE LOCAL VALUES OF +* BETA, T, RND, EPS, EMIN AND RMIN. +* +* THROUGHOUT THIS ROUTINE WE USE THE FUNCTION DLAMC3 TO ENSURE +* THAT RELEVANT VALUES ARE STORED AND NOT HELD IN REGISTERS, OR +* ARE NOT AFFECTED BY OPTIMIZERS. +* +* DLAMC1 RETURNS THE PARAMETERS LBETA, LT, LRND AND LIEEE1. +* + CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) +* +* START TO FIND EPS. +* + B = LBETA + A = B**( -LT ) + LEPS = A +* +* TRY SOME TRICKS TO SEE WHETHER OR NOT THIS IS THE CORRECT EPS. +* + B = TWO / 3 + HALF = ONE / 2 + SIXTH = DLAMC3( B, -HALF ) + THIRD = DLAMC3( SIXTH, SIXTH ) + B = DLAMC3( THIRD, -HALF ) + B = DLAMC3( B, SIXTH ) + B = ABS( B ) + IF( B.LT.LEPS ) + $ B = LEPS +* + LEPS = 1 +* +*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP + 10 CONTINUE + IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN + LEPS = B + C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) + C = DLAMC3( HALF, -C ) + B = DLAMC3( HALF, C ) + C = DLAMC3( HALF, -B ) + B = DLAMC3( HALF, C ) + GO TO 10 + END IF +*+ END WHILE +* + IF( A.LT.LEPS ) + $ LEPS = A +* +* COMPUTATION OF EPS COMPLETE. +* +* NOW FIND EMIN. LET A = + OR - 1, AND + OR - (1 + BASE**(-3)). +* KEEP DIVIDING A BY BETA UNTIL (GRADUAL) UNDERFLOW OCCURS. THIS +* IS DETECTED WHEN WE CANNOT RECOVER THE PREVIOUS A. +* + RBASE = ONE / LBETA + SMALL = ONE + DO 20 I = 1, 3 + SMALL = DLAMC3( SMALL*RBASE, ZERO ) + 20 CONTINUE + A = DLAMC3( ONE, SMALL ) + CALL DLAMC4( NGPMIN, ONE, LBETA ) + CALL DLAMC4( NGNMIN, -ONE, LBETA ) + CALL DLAMC4( GPMIN, A, LBETA ) + CALL DLAMC4( GNMIN, -A, LBETA ) + IEEE = .FALSE. +* + IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN + IF( NGPMIN.EQ.GPMIN ) THEN + LEMIN = NGPMIN +* ( NON TWOS-COMPLEMENT MACHINES, NO GRADUAL UNDERFLOW; +* E.G., VAX ) + ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN + LEMIN = NGPMIN - 1 + LT + IEEE = .TRUE. +* ( NON TWOS-COMPLEMENT MACHINES, WITH GRADUAL UNDERFLOW; +* E.G., IEEE STANDARD FOLLOWERS ) + ELSE + LEMIN = MIN( NGPMIN, GPMIN ) +* ( A GUESS; NO KNOWN MACHINE ) + IWARN = .TRUE. + END IF +* + ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN + IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN + LEMIN = MAX( NGPMIN, NGNMIN ) +* ( TWOS-COMPLEMENT MACHINES, NO GRADUAL UNDERFLOW; +* E.G., CYBER 205 ) + ELSE + LEMIN = MIN( NGPMIN, NGNMIN ) +* ( A GUESS; NO KNOWN MACHINE ) + IWARN = .TRUE. + END IF +* + ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. + $ ( GPMIN.EQ.GNMIN ) ) THEN + IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN + LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT +* ( TWOS-COMPLEMENT MACHINES WITH GRADUAL UNDERFLOW; +* NO KNOWN MACHINE ) + ELSE + LEMIN = MIN( NGPMIN, NGNMIN ) +* ( A GUESS; NO KNOWN MACHINE ) + IWARN = .TRUE. + END IF +* + ELSE + LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) +* ( A GUESS; NO KNOWN MACHINE ) + IWARN = .TRUE. + END IF +*** +* COMMENT OUT THIS IF BLOCK IF EMIN IS OK + IF( IWARN ) THEN + FIRST = .TRUE. + WRITE( 6, FMT = 9999 )LEMIN + END IF +*** +* +* ASSUME IEEE ARITHMETIC IF WE FOUND DENORMALISED NUMBERS ABOVE, +* OR IF ARITHMETIC SEEMS TO ROUND IN THE IEEE STYLE, DETERMINED +* IN ROUTINE DLAMC1. A TRUE IEEE MACHINE SHOULD HAVE BOTH THINGS +* TRUE; HOWEVER, FAULTY MACHINES MAY HAVE ONE OR THE OTHER. +* + IEEE = IEEE .OR. LIEEE1 +* +* COMPUTE RMIN BY SUCCESSIVE DIVISION BY BETA. WE COULD COMPUTE +* RMIN AS BASE**( EMIN - 1 ), BUT SOME MACHINES UNDERFLOW DURING +* THIS COMPUTATION. +* + LRMIN = 1 + DO 30 I = 1, 1 - LEMIN + LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) + 30 CONTINUE +* +* FINALLY, CALL DLAMC5 TO COMPUTE EMAX AND RMAX. +* + CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) + END IF +* + BETA = LBETA + T = LT + RND = LRND + EPS = LEPS + EMIN = LEMIN + RMIN = LRMIN + EMAX = LEMAX + RMAX = LRMAX +* + RETURN +* + 9999 FORMAT( / / ' WARNING. THE VALUE EMIN MAY BE INCORRECT:-', + $ ' EMIN = ', I8, / + $ ' IF, AFTER INSPECTION, THE VALUE EMIN LOOKS', + $ ' ACCEPTABLE PLEASE COMMENT OUT ', + $ / ' THE IF BLOCK AS MARKED WITHIN THE CODE OF ROUTINE', + $ ' DLAMC2,', / ' OTHERWISE SUPPLY EMIN EXPLICITLY.', / ) +* +* END OF DLAMC2 +* + END +* +************************************************************************ +* + DOUBLE PRECISION FUNCTION DLAMC3( A, B ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + DOUBLE PRECISION A, B +* .. +* +* PURPOSE +* ======= +* +* DLAMC3 IS INTENDED TO FORCE A AND B TO BE STORED PRIOR TO DOING +* THE ADDITION OF A AND B , FOR USE IN SITUATIONS WHERE OPTIMIZERS +* MIGHT HOLD ONE OF THESE IN A REGISTER. +* +* ARGUMENTS +* ========= +* +* A, B (INPUT) DOUBLE PRECISION +* THE VALUES A AND B. +* +* ===================================================================== +* +* .. EXECUTABLE STATEMENTS .. +* + DLAMC3 = A + B +* + RETURN +* +* END OF DLAMC3 +* + END +* +************************************************************************ +* + SUBROUTINE DLAMC4( EMIN, START, BASE ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + INTEGER BASE, EMIN + DOUBLE PRECISION START +* .. +* +* PURPOSE +* ======= +* +* DLAMC4 IS A SERVICE ROUTINE FOR DLAMC2. +* +* ARGUMENTS +* ========= +* +* EMIN (OUTPUT) EMIN +* THE MINIMUM EXPONENT BEFORE (GRADUAL) UNDERFLOW, COMPUTED BY +* SETTING A = START AND DIVIDING BY BASE UNTIL THE PREVIOUS A +* CAN NOT BE RECOVERED. +* +* START (INPUT) DOUBLE PRECISION +* THE STARTING POINT FOR DETERMINING EMIN. +* +* BASE (INPUT) INTEGER +* THE BASE OF THE MACHINE. +* +* ===================================================================== +* +* .. LOCAL SCALARS .. + INTEGER I + DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO +* .. +* .. EXTERNAL FUNCTIONS .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. EXECUTABLE STATEMENTS .. +* + A = START + ONE = 1 + RBASE = ONE / BASE + ZERO = 0 + EMIN = 1 + B1 = DLAMC3( A*RBASE, ZERO ) + C1 = A + C2 = A + D1 = A + D2 = A +*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. +* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP + 10 CONTINUE + IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. + $ ( D2.EQ.A ) ) THEN + EMIN = EMIN - 1 + A = B1 + B1 = DLAMC3( A / BASE, ZERO ) + C1 = DLAMC3( B1*BASE, ZERO ) + D1 = ZERO + DO 20 I = 1, BASE + D1 = D1 + B1 + 20 CONTINUE + B2 = DLAMC3( A*RBASE, ZERO ) + C2 = DLAMC3( B2 / RBASE, ZERO ) + D2 = ZERO + DO 30 I = 1, BASE + D2 = D2 + B2 + 30 CONTINUE + GO TO 10 + END IF +*+ END WHILE +* + RETURN +* +* END OF DLAMC4 +* + END +* +************************************************************************ +* + SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + LOGICAL IEEE + INTEGER BETA, EMAX, EMIN, P + DOUBLE PRECISION RMAX +* .. +* +* PURPOSE +* ======= +* +* DLAMC5 ATTEMPTS TO COMPUTE RMAX, THE LARGEST MACHINE FLOATING-POINT +* NUMBER, WITHOUT OVERFLOW. IT ASSUMES THAT EMAX + ABS(EMIN) SUM +* APPROXIMATELY TO A POWER OF 2. IT WILL FAIL ON MACHINES WHERE THIS +* ASSUMPTION DOES NOT HOLD, FOR EXAMPLE, THE CYBER 205 (EMIN = -28625, +* EMAX = 28718). IT WILL ALSO FAIL IF THE VALUE SUPPLIED FOR EMIN IS +* TOO LARGE (I.E. TOO CLOSE TO ZERO), PROBABLY WITH OVERFLOW. +* +* ARGUMENTS +* ========= +* +* BETA (INPUT) INTEGER +* THE BASE OF FLOATING-POINT ARITHMETIC. +* +* P (INPUT) INTEGER +* THE NUMBER OF BASE BETA DIGITS IN THE MANTISSA OF A +* FLOATING-POINT VALUE. +* +* EMIN (INPUT) INTEGER +* THE MINIMUM EXPONENT BEFORE (GRADUAL) UNDERFLOW. +* +* IEEE (INPUT) LOGICAL +* A LOGICAL FLAG SPECIFYING WHETHER OR NOT THE ARITHMETIC +* SYSTEM IS THOUGHT TO COMPLY WITH THE IEEE STANDARD. +* +* EMAX (OUTPUT) INTEGER +* THE LARGEST EXPONENT BEFORE OVERFLOW +* +* RMAX (OUTPUT) DOUBLE PRECISION +* THE LARGEST MACHINE FLOATING-POINT NUMBER. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP + DOUBLE PRECISION OLDY, RECBAS, Y, Z +* .. +* .. EXTERNAL FUNCTIONS .. + DOUBLE PRECISION DLAMC3 + EXTERNAL DLAMC3 +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MOD +* .. +* .. EXECUTABLE STATEMENTS .. +* +* FIRST COMPUTE LEXP AND UEXP, TWO POWERS OF 2 THAT BOUND +* ABS(EMIN). WE THEN ASSUME THAT EMAX + ABS(EMIN) WILL SUM +* APPROXIMATELY TO THE BOUND THAT IS CLOSEST TO ABS(EMIN). +* (EMAX IS THE EXPONENT OF THE REQUIRED NUMBER RMAX). +* + LEXP = 1 + EXBITS = 1 + 10 CONTINUE + TRY = LEXP*2 + IF( TRY.LE.( -EMIN ) ) THEN + LEXP = TRY + EXBITS = EXBITS + 1 + GO TO 10 + END IF + IF( LEXP.EQ.-EMIN ) THEN + UEXP = LEXP + ELSE + UEXP = TRY + EXBITS = EXBITS + 1 + END IF +* +* NOW -LEXP IS LESS THAN OR EQUAL TO EMIN, AND -UEXP IS GREATER +* THAN OR EQUAL TO EMIN. EXBITS IS THE NUMBER OF BITS NEEDED TO +* STORE THE EXPONENT. +* + IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN + EXPSUM = 2*LEXP + ELSE + EXPSUM = 2*UEXP + END IF +* +* EXPSUM IS THE EXPONENT RANGE, APPROXIMATELY EQUAL TO +* EMAX - EMIN + 1 . +* + EMAX = EXPSUM + EMIN - 1 + NBITS = 1 + EXBITS + P +* +* NBITS IS THE TOTAL NUMBER OF BITS NEEDED TO STORE A +* FLOATING-POINT NUMBER. +* + IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN +* +* EITHER THERE ARE AN ODD NUMBER OF BITS USED TO STORE A +* FLOATING-POINT NUMBER, WHICH IS UNLIKELY, OR SOME BITS ARE +* NOT USED IN THE REPRESENTATION OF NUMBERS, WHICH IS POSSIBLE, +* (E.G. CRAY MACHINES) OR THE MANTISSA HAS AN IMPLICIT BIT, +* (E.G. IEEE MACHINES, DEC VAX MACHINES), WHICH IS PERHAPS THE +* MOST LIKELY. WE HAVE TO ASSUME THE LAST ALTERNATIVE. +* IF THIS IS TRUE, THEN WE NEED TO REDUCE EMAX BY ONE BECAUSE +* THERE MUST BE SOME WAY OF REPRESENTING ZERO IN AN IMPLICIT-BIT +* SYSTEM. ON MACHINES LIKE CRAY, WE ARE REDUCING EMAX BY ONE +* UNNECESSARILY. +* + EMAX = EMAX - 1 + END IF +* + IF( IEEE ) THEN +* +* ASSUME WE ARE ON AN IEEE MACHINE WHICH RESERVES ONE EXPONENT +* FOR INFINITY AND NAN. +* + EMAX = EMAX - 1 + END IF +* +* NOW CREATE RMAX, THE LARGEST MACHINE NUMBER, WHICH SHOULD +* BE EQUAL TO (1.0 - BETA**(-P)) * BETA**EMAX . +* +* FIRST COMPUTE 1.0 - BETA**(-P), BEING CAREFUL THAT THE +* RESULT IS LESS THAN 1.0 . +* + RECBAS = ONE / BETA + Z = BETA - ONE + Y = ZERO + DO 20 I = 1, P + Z = Z*RECBAS + IF( Y.LT.ONE ) + $ OLDY = Y + Y = DLAMC3( Y, Z ) + 20 CONTINUE + IF( Y.GE.ONE ) + $ Y = OLDY +* +* NOW MULTIPLY BY BETA**EMAX TO GET RMAX. +* + DO 30 I = 1, EMAX + Y = DLAMC3( Y*BETA, ZERO ) + 30 CONTINUE +* + RMAX = Y + RETURN +* +* END OF DLAMC5 +* + END +CUT HERE............ +CAT > DLAPY2.F <<'CUT HERE............' + DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + DOUBLE PRECISION X, Y +* .. +* +* PURPOSE +* ======= +* +* DLAPY2 RETURNS SQRT(X**2+Y**2), TAKING CARE NOT TO CAUSE UNNECESSARY +* OVERFLOW. +* +* ARGUMENTS +* ========= +* +* X (INPUT) DOUBLE PRECISION +* Y (INPUT) DOUBLE PRECISION +* X AND Y SPECIFY THE VALUES X AND Y. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D0 ) +* .. +* .. LOCAL SCALARS .. + DOUBLE PRECISION W, XABS, YABS, Z +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. EXECUTABLE STATEMENTS .. +* + XABS = ABS( X ) + YABS = ABS( Y ) + W = MAX( XABS, YABS ) + Z = MIN( XABS, YABS ) + IF( Z.EQ.ZERO ) THEN + DLAPY2 = W + ELSE + DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) + END IF + RETURN +* +* END OF DLAPY2 +* + END +CUT HERE............ +CAT > ILAENV.F <<'CUT HERE............' + INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, + $ N4 ) +* +* -- LAPACK AUXILIARY ROUTINE (PRELIMINARY VERSION) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* FEBRUARY 20, 1992 +* +* .. SCALAR ARGUMENTS .. + CHARACTER*( * ) NAME, OPTS + INTEGER ISPEC, N1, N2, N3, N4 +* .. +* +* PURPOSE +* ======= +* +* ILAENV IS CALLED FROM THE LAPACK ROUTINES TO CHOOSE PROBLEM-DEPENDENT +* PARAMETERS FOR THE LOCAL ENVIRONMENT. SEE ISPEC FOR A DESCRIPTION OF +* THE PARAMETERS. +* +* THIS VERSION PROVIDES A SET OF PARAMETERS WHICH SHOULD GIVE GOOD, +* BUT NOT OPTIMAL, PERFORMANCE ON MANY OF THE CURRENTLY AVAILABLE +* COMPUTERS. USERS ARE ENCOURAGED TO MODIFY THIS SUBROUTINE TO SET +* THE TUNING PARAMETERS FOR THEIR PARTICULAR MACHINE USING THE OPTION +* AND PROBLEM SIZE INFORMATION IN THE ARGUMENTS. +* +* THIS ROUTINE WILL NOT FUNCTION CORRECTLY IF IT IS CONVERTED TO ALL +* LOWER CASE. CONVERTING IT TO ALL UPPER CASE IS ALLOWED. +* +* ARGUMENTS +* ========= +* +* ISPEC (INPUT) INTEGER +* SPECIFIES THE PARAMETER TO BE RETURNED AS THE VALUE OF +* ILAENV. +* = 1: THE OPTIMAL BLOCKSIZE; IF THIS VALUE IS 1, AN UNBLOCKED +* ALGORITHM WILL GIVE THE BEST PERFORMANCE. +* = 2: THE MINIMUM BLOCK SIZE FOR WHICH THE BLOCK ROUTINE +* SHOULD BE USED; IF THE USABLE BLOCK SIZE IS LESS THAN +* THIS VALUE, AN UNBLOCKED ROUTINE SHOULD BE USED. +* = 3: THE CROSSOVER POINT (IN A BLOCK ROUTINE, FOR N LESS +* THAN THIS VALUE, AN UNBLOCKED ROUTINE SHOULD BE USED) +* = 4: THE NUMBER OF SHIFTS, USED IN THE NONSYMMETRIC +* EIGENVALUE ROUTINES +* = 5: THE MINIMUM COLUMN DIMENSION FOR BLOCKING TO BE USED; +* RECTANGULAR BLOCKS MUST HAVE DIMENSION AT LEAST K BY M, +* WHERE K IS GIVEN BY ILAENV(2,...) AND M BY ILAENV(5,...) +* = 6: THE CROSSOVER POINT FOR THE SVD (WHEN REDUCING AN M BY N +* MATRIX TO BIDIAGONAL FORM, IF MAX(M,N)/MIN(M,N) EXCEEDS +* THIS VALUE, A QR FACTORIZATION IS USED FIRST TO REDUCE +* THE MATRIX TO A TRIANGULAR FORM.) +* = 7: THE NUMBER OF PROCESSORS +* = 8: THE CROSSOVER POINT FOR THE MULTISHIFT QR AND QZ METHODS +* FOR NONSYMMETRIC EIGENVALUE PROBLEMS. +* +* NAME (INPUT) CHARACTER*(*) +* THE NAME OF THE CALLING SUBROUTINE, IN EITHER UPPER CASE OR +* LOWER CASE. +* +* OPTS (INPUT) CHARACTER*(*) +* THE CHARACTER OPTIONS TO THE SUBROUTINE NAME, CONCATENATED +* INTO A SINGLE CHARACTER STRING. FOR EXAMPLE, UPLO = 'U', +* TRANS = 'T', AND DIAG = 'N' FOR A TRIANGULAR ROUTINE WOULD +* BE SPECIFIED AS OPTS = 'UTN'. +* +* N1 (INPUT) INTEGER +* N2 (INPUT) INTEGER +* N3 (INPUT) INTEGER +* N4 (INPUT) INTEGER +* PROBLEM DIMENSIONS FOR THE SUBROUTINE NAME; THESE MAY NOT ALL +* BE REQUIRED. +* +* (ILAENV) (OUTPUT) INTEGER +* >= 0: THE VALUE OF THE PARAMETER SPECIFIED BY ISPEC +* < 0: IF ILAENV = -K, THE K-TH ARGUMENT HAD AN ILLEGAL VALUE. +* +* FURTHER DETAILS +* =============== +* +* THE FOLLOWING CONVENTIONS HAVE BEEN USED WHEN CALLING ILAENV FROM THE +* LAPACK ROUTINES: +* 1) OPTS IS A CONCATENATION OF ALL OF THE CHARACTER OPTIONS TO +* SUBROUTINE NAME, IN THE SAME ORDER THAT THEY APPEAR IN THE +* ARGUMENT LIST FOR NAME, EVEN IF THEY ARE NOT USED IN DETERMINING +* THE VALUE OF THE PARAMETER SPECIFIED BY ISPEC. +* 2) THE PROBLEM DIMENSIONS N1, N2, N3, N4 ARE SPECIFIED IN THE ORDER +* THAT THEY APPEAR IN THE ARGUMENT LIST FOR NAME. N1 IS USED +* FIRST, N2 SECOND, AND SO ON, AND UNUSED PROBLEM DIMENSIONS ARE +* PASSED A VALUE OF -1. +* 3) THE PARAMETER VALUE RETURNED BY ILAENV IS CHECKED FOR VALIDITY IN +* THE CALLING SUBROUTINE. FOR EXAMPLE, ILAENV IS USED TO RETRIEVE +* THE OPTIMAL BLOCKSIZE FOR STRTRI AS FOLLOWS: +* +* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) +* IF( NB.LE.1 ) NB = MAX( 1, N ) +* +* ===================================================================== +* +* .. LOCAL SCALARS .. + LOGICAL CNAME, SNAME + CHARACTER*1 C1 + CHARACTER*2 C2, C4 + CHARACTER*3 C3 + CHARACTER*6 SUBNAM + INTEGER I, IC, IZ, NB, NBMIN, NX +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC CHAR, ICHAR, INT, MIN, REAL +* .. +* .. EXECUTABLE STATEMENTS .. +* + GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC +* +* INVALID VALUE FOR ISPEC +* + ILAENV = -1 + RETURN +* + 100 CONTINUE +* +* CONVERT NAME TO UPPER CASE IF THE FIRST CHARACTER IS LOWER CASE. +* + ILAENV = 1 + SUBNAM = NAME + IC = ICHAR( SUBNAM( 1:1 ) ) + IZ = ICHAR( 'Z' ) + IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN +* +* ASCII CHARACTER SET +* + IF( IC.GE.97 .AND. IC.LE.122 ) THEN + SUBNAM( 1:1 ) = CHAR( IC-32 ) + DO 10 I = 2, 6 + IC = ICHAR( SUBNAM( I:I ) ) + IF( IC.GE.97 .AND. IC.LE.122 ) + $ SUBNAM( I:I ) = CHAR( IC-32 ) + 10 CONTINUE + END IF +* + ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN +* +* EBCDIC CHARACTER SET +* + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN + SUBNAM( 1:1 ) = CHAR( IC+64 ) + DO 20 I = 2, 6 + IC = ICHAR( SUBNAM( I:I ) ) + IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. + $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. + $ ( IC.GE.162 .AND. IC.LE.169 ) ) + $ SUBNAM( I:I ) = CHAR( IC+64 ) + 20 CONTINUE + END IF +* + ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN +* +* PRIME MACHINES: ASCII+128 +* + IF( IC.GE.225 .AND. IC.LE.250 ) THEN + SUBNAM( 1:1 ) = CHAR( IC-32 ) + DO 30 I = 2, 6 + IC = ICHAR( SUBNAM( I:I ) ) + IF( IC.GE.225 .AND. IC.LE.250 ) + $ SUBNAM( I:I ) = CHAR( IC-32 ) + 30 CONTINUE + END IF + END IF +* + C1 = SUBNAM( 1:1 ) + SNAME = C1.EQ.'S' .OR. C1.EQ.'D' + CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' + IF( .NOT.( CNAME .OR. SNAME ) ) + $ RETURN + C2 = SUBNAM( 2:3 ) + C3 = SUBNAM( 4:6 ) + C4 = C3( 2:3 ) +* + GO TO ( 110, 200, 300 ) ISPEC +* + 110 CONTINUE +* +* ISPEC = 1: BLOCK SIZE +* +* IN THESE EXAMPLES, SEPARATE CODE IS PROVIDED FOR SETTING NB FOR +* REAL AND COMPLEX. WE ASSUME THAT NB WILL TAKE THE SAME VALUE IN +* SINGLE OR DOUBLE PRECISION. +* + NB = 1 +* + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NB = 32 + ELSE + NB = 32 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'PO' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NB = 1 + ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRF' ) THEN + NB = 64 + ELSE IF( C3.EQ.'TRD' ) THEN + NB = 1 + ELSE IF( C3.EQ.'GST' ) THEN + NB = 64 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NB = 32 + END IF + ELSE IF( C3( 1:1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NB = 32 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NB = 32 + END IF + ELSE IF( C3( 1:1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NB = 32 + END IF + END IF + ELSE IF( C2.EQ.'GB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N4.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'PB' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + ELSE + IF( N2.LE.64 ) THEN + NB = 1 + ELSE + NB = 32 + END IF + END IF + END IF + ELSE IF( C2.EQ.'TR' ) THEN + IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( C2.EQ.'LA' ) THEN + IF( C3.EQ.'UUM' ) THEN + IF( SNAME ) THEN + NB = 64 + ELSE + NB = 64 + END IF + END IF + ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN + IF( C3.EQ.'EBZ' ) THEN + NB = 1 + END IF + END IF + ILAENV = NB + RETURN +* + 200 CONTINUE +* +* ISPEC = 2: MINIMUM BLOCK SIZE +* + NBMIN = 2 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( C3.EQ.'TRI' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( C3.EQ.'TRF' ) THEN + IF( SNAME ) THEN + NBMIN = 2 + ELSE + NBMIN = 2 + END IF + ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NBMIN = 2 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1:1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NBMIN = 2 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NBMIN = 2 + END IF + ELSE IF( C3( 1:1 ).EQ.'M' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NBMIN = 2 + END IF + END IF + END IF + ILAENV = NBMIN + RETURN +* + 300 CONTINUE +* +* ISPEC = 3: CROSSOVER POINT +* + NX = 0 + IF( C2.EQ.'GE' ) THEN + IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. + $ C3.EQ.'QLF' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'HRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + ELSE IF( C3.EQ.'BRD' ) THEN + IF( SNAME ) THEN + NX = 128 + ELSE + NX = 128 + END IF + END IF + ELSE IF( C2.EQ.'SY' ) THEN + IF( SNAME .AND. C3.EQ.'TRD' ) THEN + NX = 1 + END IF + ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN + IF( C3.EQ.'TRD' ) THEN + NX = 1 + END IF + ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NX = 128 + END IF + END IF + ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN + IF( C3( 1:1 ).EQ.'G' ) THEN + IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. + $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. + $ C4.EQ.'BR' ) THEN + NX = 128 + END IF + END IF + END IF + ILAENV = NX + RETURN +* + 400 CONTINUE +* +* ISPEC = 4: NUMBER OF SHIFTS (USED BY XHSEQR) +* + ILAENV = 6 + RETURN +* + 500 CONTINUE +* +* ISPEC = 5: MINIMUM COLUMN DIMENSION (NOT USED) +* + ILAENV = 2 + RETURN +* + 600 CONTINUE +* +* ISPEC = 6: CROSSOVER POINT FOR SVD (USED BY XGELSS AND XGESVD) +* + ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) + RETURN +* + 700 CONTINUE +* +* ISPEC = 7: NUMBER OF PROCESSORS (NOT USED) +* + ILAENV = 1 + RETURN +* + 800 CONTINUE +* +* ISPEC = 8: CROSSOVER POINT FOR MULTISHIFT (USED BY XHSEQR) +* + ILAENV = 50 + RETURN +* +* END OF ILAENV +* + END +CUT HERE............ +CAT > DLANSY.F <<'CUT HERE............' + DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + CHARACTER NORM, UPLO + INTEGER LDA, N +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* PURPOSE +* ======= +* +* DLANSY RETURNS THE VALUE OF THE ONE NORM, OR THE FROBENIUS NORM, OR +* THE INFINITY NORM, OR THE ELEMENT OF LARGEST ABSOLUTE VALUE OF A +* REAL SYMMETRIC MATRIX A. +* +* DESCRIPTION +* =========== +* +* DLANSY RETURNS THE VALUE +* +* DLANSY = ( MAX(ABS(A(I,J))), NORM = 'M' OR 'M' +* ( +* ( NORM1(A), NORM = '1', 'O' OR 'O' +* ( +* ( NORMI(A), NORM = 'I' OR 'I' +* ( +* ( NORMF(A), NORM = 'F', 'F', 'E' OR 'E' +* +* WHERE NORM1 DENOTES THE ONE NORM OF A MATRIX (MAXIMUM COLUMN SUM), +* NORMI DENOTES THE INFINITY NORM OF A MATRIX (MAXIMUM ROW SUM) AND +* NORMF DENOTES THE FROBENIUS NORM OF A MATRIX (SQUARE ROOT OF SUM OF +* SQUARES). NOTE THAT MAX(ABS(A(I,J))) IS NOT A MATRIX NORM. +* +* ARGUMENTS +* ========= +* +* NORM (INPUT) CHARACTER*1 +* SPECIFIES THE VALUE TO BE RETURNED IN DLANSY AS DESCRIBED +* ABOVE. +* +* UPLO (INPUT) CHARACTER*1 +* SPECIFIES WHETHER THE UPPER OR LOWER TRIANGULAR PART OF THE +* SYMMETRIC MATRIX A IS TO BE REFERENCED. +* = 'U': UPPER TRIANGULAR PART OF A IS REFERENCED +* = 'L': LOWER TRIANGULAR PART OF A IS REFERENCED +* +* N (INPUT) INTEGER +* THE ORDER OF THE MATRIX A. N >= 0. WHEN N = 0, DLANSY IS +* SET TO ZERO. +* +* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* THE SYMMETRIC MATRIX A. IF UPLO = 'U', THE LEADING N BY N +* UPPER TRIANGULAR PART OF A CONTAINS THE UPPER TRIANGULAR PART +* OF THE MATRIX A, AND THE STRICTLY LOWER TRIANGULAR PART OF A +* IS NOT REFERENCED. IF UPLO = 'L', THE LEADING N BY N LOWER +* TRIANGULAR PART OF A CONTAINS THE LOWER TRIANGULAR PART OF +* THE MATRIX A, AND THE STRICTLY UPPER TRIANGULAR PART OF A IS +* NOT REFERENCED. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(N,1). +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK), +* WHERE LWORK >= N WHEN NORM = 'I' OR '1' OR 'O'; OTHERWISE, +* WORK IS NOT REFERENCED. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER I, J + DOUBLE PRECISION ABSA, SCALE, SUM, VALUE +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLASSQ +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. EXECUTABLE STATEMENTS .. +* + IF( N.EQ.0 ) THEN + VALUE = ZERO + ELSE IF( LSAME( NORM, 'M' ) ) THEN +* +* FIND MAX(ABS(A(I,J))). +* + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + DO 20 J = 1, N + DO 10 I = 1, J + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40 J = 1, N + DO 30 I = J, N + VALUE = MAX( VALUE, ABS( A( I, J ) ) ) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR. + $ ( NORM.EQ.'1' ) ) THEN +* +* FIND NORMI(A) ( = NORM1(A), SINCE A IS SYMMETRIC). +* + VALUE = ZERO + IF( LSAME( UPLO, 'U' ) ) THEN + DO 60 J = 1, N + SUM = ZERO + DO 50 I = 1, J - 1 + ABSA = ABS( A( I, J ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + 50 CONTINUE + WORK( J ) = SUM + ABS( A( J, J ) ) + 60 CONTINUE + DO 70 I = 1, N + VALUE = MAX( VALUE, WORK( I ) ) + 70 CONTINUE + ELSE + DO 80 I = 1, N + WORK( I ) = ZERO + 80 CONTINUE + DO 100 J = 1, N + SUM = WORK( J ) + ABS( A( J, J ) ) + DO 90 I = J + 1, N + ABSA = ABS( A( I, J ) ) + SUM = SUM + ABSA + WORK( I ) = WORK( I ) + ABSA + 90 CONTINUE + VALUE = MAX( VALUE, SUM ) + 100 CONTINUE + END IF + ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN +* +* FIND NORMF(A). +* + SCALE = ZERO + SUM = ONE + IF( LSAME( UPLO, 'U' ) ) THEN + DO 110 J = 2, N + CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM ) + 110 CONTINUE + ELSE + DO 120 J = 1, N - 1 + CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM ) + 120 CONTINUE + END IF + SUM = 2*SUM + CALL DLASSQ( N, A, LDA+1, SCALE, SUM ) + VALUE = SCALE*SQRT( SUM ) + END IF +* + DLANSY = VALUE + RETURN +* +* END OF DLANSY +* + END +CUT HERE............ +CAT > DLASSQ.F <<'CUT HERE............' + SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + INTEGER INCX, N + DOUBLE PRECISION SCALE, SUMSQ +* .. +* .. ARRAY ARGUMENTS .. + DOUBLE PRECISION X( * ) +* .. +* +* PURPOSE +* ======= +* +* DLASSQ RETURNS THE VALUES SCL AND SMSQ SUCH THAT +* +* ( SCL**2 )*SMSQ = X( 1 )**2 +...+ X( N )**2 + ( SCALE**2 )*SUMSQ, +* +* WHERE X( I ) = X( 1 + ( I - 1 )*INCX ). THE VALUE OF SUMSQ IS +* ASSUMED TO BE NON-NEGATIVE AND SCL RETURNS THE VALUE +* +* SCL = MAX( SCALE, ABS( X( I ) ) ). +* +* SCALE AND SUMSQ MUST BE SUPPLIED IN SCALE AND SUMSQ AND +* SCL AND SMSQ ARE OVERWRITTEN ON SCALE AND SUMSQ RESPECTIVELY. +* +* THE ROUTINE MAKES ONLY ONE PASS THROUGH THE VECTOR X. +* +* ARGUMENTS +* ========= +* +* N (INPUT) INTEGER +* THE NUMBER OF ELEMENTS TO BE USED FROM THE VECTOR X. +* +* X (INPUT) DOUBLE PRECISION +* THE VECTOR FOR WHICH A SCALED SUM OF SQUARES IS COMPUTED. +* X( I ) = X( 1 + ( I - 1 )*INCX ), 1 <= I <= N. +* +* INCX (INPUT) INTEGER +* THE INCREMENT BETWEEN SUCCESSIVE VALUES OF THE VECTOR X. +* INCX > 0. +* +* SCALE (INPUT/OUTPUT) DOUBLE PRECISION +* ON ENTRY, THE VALUE SCALE IN THE EQUATION ABOVE. +* ON EXIT, SCALE IS OVERWRITTEN WITH SCL , THE SCALING FACTOR +* FOR THE SUM OF SQUARES. +* +* SUMSQ (INPUT/OUTPUT) DOUBLE PRECISION +* ON ENTRY, THE VALUE SUMSQ IN THE EQUATION ABOVE. +* ON EXIT, SUMSQ IS OVERWRITTEN WITH SMSQ , THE BASIC SUM OF +* SQUARES FROM WHICH SCL HAS BEEN FACTORED OUT. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D+0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER IX + DOUBLE PRECISION ABSXI +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS +* .. +* .. EXECUTABLE STATEMENTS .. +* + IF( N.GT.0 ) THEN + DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX + IF( X( IX ).NE.ZERO ) THEN + ABSXI = ABS( X( IX ) ) + IF( SCALE.LT.ABSXI ) THEN + SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 + SCALE = ABSXI + ELSE + SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 + END IF + END IF + 10 CONTINUE + END IF + RETURN +* +* END OF DLASSQ +* + END +CUT HERE............ +C ----------------- BELOW IS DSYTRF ------------------- +CAT > DSYTRF.F <<'CUT HERE..........' + SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.0B) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* FEBRUARY 29, 1992 +* +* .. SCALAR ARGUMENTS .. + CHARACTER UPLO + INTEGER INFO, LDA, LWORK, N +* .. +* .. ARRAY ARGUMENTS .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( LWORK ) +* .. +* +* PURPOSE +* ======= +* +* DSYTRF COMPUTES THE FACTORIZATION OF A REAL SYMMETRIC MATRIX A USING +* THE BUNCH-KAUFMAN DIAGONAL PIVOTING METHOD: +* +* A = U*D*U' OR A = L*D*L' +* +* WHERE U (OR L) IS A PRODUCT OF PERMUTATION AND UNIT UPPER (LOWER) +* TRIANGULAR MATRICES, U' IS THE TRANSPOSE OF U, AND D IS SYMMETRIC AND +* BLOCK DIAGONAL WITH 1-BY-1 AND 2-BY-2 DIAGONAL BLOCKS. +* +* THIS IS THE BLOCKED VERSION OF THE ALGORITHM, CALLING LEVEL 3 BLAS. +* +* ARGUMENTS +* ========= +* +* UPLO (INPUT) CHARACTER*1 +* SPECIFIES WHETHER THE UPPER OR LOWER TRIANGULAR PART OF THE +* SYMMETRIC MATRIX A IS STORED: +* = 'U': UPPER TRIANGULAR +* = 'L': LOWER TRIANGULAR +* +* N (INPUT) INTEGER +* THE ORDER OF THE MATRIX A. N >= 0. +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* ON ENTRY, THE SYMMETRIC MATRIX A. IF UPLO = 'U', THE LEADING +* N-BY-N UPPER TRIANGULAR PART OF A CONTAINS THE UPPER +* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY LOWER +* TRIANGULAR PART OF A IS NOT REFERENCED. IF UPLO = 'L', THE +* LEADING N-BY-N LOWER TRIANGULAR PART OF A CONTAINS THE LOWER +* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY UPPER +* TRIANGULAR PART OF A IS NOT REFERENCED. +* +* ON EXIT, THE BLOCK DIAGONAL MATRIX D AND THE MULTIPLIERS USED +* TO OBTAIN THE FACTOR U OR L (SEE BELOW FOR FURTHER DETAILS). +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N). +* +* IPIV (OUTPUT) INTEGER ARRAY, DIMENSION (N) +* DETAILS OF THE INTERCHANGES AND THE BLOCK STRUCTURE OF D. +* IF IPIV(K) > 0, THEN ROWS AND COLUMNS K AND IPIV(K) WERE +* INTERCHANGED AND D(K,K) IS A 1-BY-1 DIAGONAL BLOCK. +* IF UPLO = 'U' AND IPIV(K) = IPIV(K-1) < 0, THEN ROWS AND +* COLUMNS K-1 AND -IPIV(K) WERE INTERCHANGED AND D(K-1:K,K-1:K) +* IS A 2-BY-2 DIAGONAL BLOCK. IF UPLO = 'L' AND IPIV(K) = +* IPIV(K+1) < 0, THEN ROWS AND COLUMNS K+1 AND -IPIV(K) WERE +* INTERCHANGED AND D(K:K+1,K:K+1) IS A 2-BY-2 DIAGONAL BLOCK. +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LWORK) +* IF INFO RETURNS 0, THEN WORK(1) RETURNS N*NB, THE MINIMUM +* VALUE OF LWORK REQUIRED TO USE THE OPTIMAL BLOCKSIZE. +* +* LWORK (INPUT) INTEGER +* THE LENGTH OF WORK. LWORK SHOULD BE >= N*NB, WHERE NB IS THE +* BLOCK SIZE RETURNED BY ILAENV. +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -K, THE K-TH ARGUMENT HAD AN ILLEGAL VALUE +* > 0: IF INFO = K, D(K,K) IS EXACTLY ZERO. THE FACTORIZATION +* HAS BEEN COMPLETED, BUT THE BLOCK DIAGONAL MATRIX D IS +* EXACTLY SINGULAR, AND DIVISION BY ZERO WILL OCCUR IF IT +* IS USED TO SOLVE A SYSTEM OF EQUATIONS. +* +* FURTHER DETAILS +* =============== +* +* IF UPLO = 'U', THEN A = U*D*U', WHERE +* U = P(N)*U(N)* ... *P(K)U(K)* ..., +* I.E., U IS A PRODUCT OF TERMS P(K)*U(K), WHERE K DECREASES FROM N TO +* 1 IN STEPS OF 1 OR 2, AND D IS A BLOCK DIAGONAL MATRIX WITH 1-BY-1 +* AND 2-BY-2 DIAGONAL BLOCKS D(K). P(K) IS A PERMUTATION MATRIX AS +* DEFINED BY IPIV(K), AND U(K) IS A UNIT UPPER TRIANGULAR MATRIX, SUCH +* THAT IF THE DIAGONAL BLOCK D(K) IS OF ORDER S (S = 1 OR 2), THEN +* +* ( I V 0 ) K-S +* U(K) = ( 0 I 0 ) S +* ( 0 0 I ) N-K +* K-S S N-K +* +* IF S = 1, D(K) OVERWRITES A(K,K), AND V OVERWRITES A(1:K-1,K). +* IF S = 2, THE UPPER TRIANGLE OF D(K) OVERWRITES A(K-1,K-1), A(K-1,K), +* AND A(K,K), AND V OVERWRITES A(1:K-2,K-1:K). +* +* IF UPLO = 'L', THEN A = L*D*L', WHERE +* L = P(1)*L(1)* ... *P(K)*L(K)* ..., +* I.E., L IS A PRODUCT OF TERMS P(K)*L(K), WHERE K INCREASES FROM 1 TO +* N IN STEPS OF 1 OR 2, AND D IS A BLOCK DIAGONAL MATRIX WITH 1-BY-1 +* AND 2-BY-2 DIAGONAL BLOCKS D(K). P(K) IS A PERMUTATION MATRIX AS +* DEFINED BY IPIV(K), AND L(K) IS A UNIT LOWER TRIANGULAR MATRIX, SUCH +* THAT IF THE DIAGONAL BLOCK D(K) IS OF ORDER S (S = 1 OR 2), THEN +* +* ( I 0 0 ) K-1 +* L(K) = ( 0 I 0 ) S +* ( 0 V I ) N-K-S+1 +* K-1 S N-K-S+1 +* +* IF S = 1, D(K) OVERWRITES A(K,K), AND V OVERWRITES A(K+1:N,K). +* IF S = 2, THE LOWER TRIANGLE OF D(K) OVERWRITES A(K,K), A(K+1,K), +* AND A(K+1,K+1), AND V OVERWRITES A(K+2:N,K:K+1). +* +* ===================================================================== +* +* .. LOCAL SCALARS .. + LOGICAL UPPER + INTEGER IINFO, IWS, J, K, KB, LDWORK, NB, NBMIN +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + INTEGER ILAENV + EXTERNAL LSAME, ILAENV +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLASYF, DSYTF2, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LWORK.LT.1 ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRF', -INFO ) + RETURN + END IF +* +* DETERMINE THE BLOCK SIZE +* + NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 ) + NBMIN = 2 + LDWORK = N + IF( NB.GT.1 .AND. NB.LT.N ) THEN + IWS = LDWORK*NB + IF( LWORK.LT.IWS ) THEN + NB = MAX( LWORK / LDWORK, 1 ) + NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF', UPLO, N, -1, -1, -1 ) ) + END IF + ELSE + IWS = 1 + END IF + IF( NB.LT.NBMIN ) + $ NB = N +* + IF( UPPER ) THEN +* +* FACTORIZE A AS U*D*U' USING THE UPPER TRIANGLE OF A +* +* K IS THE MAIN LOOP INDEX, DECREASING FROM N TO 1 IN STEPS OF +* KB, WHERE KB IS THE NUMBER OF COLUMNS FACTORIZED BY DLASYF; +* KB IS EITHER NB OR NB-1, OR K FOR THE LAST BLOCK +* + K = N + 10 CONTINUE +* +* IF K < 1, EXIT FROM LOOP +* + IF( K.LT.1 ) + $ GO TO 40 +* + IF( K.GT.NB ) THEN +* +* FACTORIZE COLUMNS K-KB+1:K OF A AND USE BLOCKED CODE TO +* UPDATE COLUMNS 1:K-KB +* + CALL DLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK, + $ IINFO ) + ELSE +* +* USE UNBLOCKED CODE TO FACTORIZE COLUMNS 1:K OF A +* + CALL DSYTF2( UPLO, K, A, LDA, IPIV, IINFO ) + KB = K + END IF +* +* SET INFO ON THE FIRST OCCURRENCE OF A ZERO PIVOT +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO +* +* DECREASE K AND RETURN TO THE START OF THE MAIN LOOP +* + K = K - KB + GO TO 10 +* + ELSE +* +* FACTORIZE A AS L*D*L' USING THE LOWER TRIANGLE OF A +* +* K IS THE MAIN LOOP INDEX, INCREASING FROM 1 TO N IN STEPS OF +* KB, WHERE KB IS THE NUMBER OF COLUMNS FACTORIZED BY DLASYF; +* KB IS EITHER NB OR NB-1, OR N-K+1 FOR THE LAST BLOCK +* + K = 1 + 20 CONTINUE +* +* IF K > N, EXIT FROM LOOP +* + IF( K.GT.N ) + $ GO TO 40 +* + IF( K.LE.N-NB ) THEN +* +* FACTORIZE COLUMNS K:K+KB-1 OF A AND USE BLOCKED CODE TO +* UPDATE COLUMNS K+KB:N +* + CALL DLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ), + $ WORK, LDWORK, IINFO ) + ELSE +* +* USE UNBLOCKED CODE TO FACTORIZE COLUMNS K:N OF A +* + CALL DSYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), IINFO ) + KB = N - K + 1 + END IF +* +* SET INFO ON THE FIRST OCCURRENCE OF A ZERO PIVOT +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + K - 1 +* +* ADJUST IPIV +* + DO 30 J = K, K + KB - 1 + IF( IPIV( J ).GT.0 ) THEN + IPIV( J ) = IPIV( J ) + K - 1 + ELSE + IPIV( J ) = IPIV( J ) - K + 1 + END IF + 30 CONTINUE +* +* INCREASE K AND RETURN TO THE START OF THE MAIN LOOP +* + K = K + KB + GO TO 20 +* + END IF +* + 40 CONTINUE + WORK( 1 ) = IWS + RETURN +* +* END OF DSYTRF +* + END +CUT HERE.......... +CAT > DSYTF2.F <<'CUT HERE..........' + SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.0B) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. ARRAY ARGUMENTS .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* PURPOSE +* ======= +* +* DSYTF2 COMPUTES THE FACTORIZATION OF A REAL SYMMETRIC MATRIX A USING +* THE BUNCH-KAUFMAN DIAGONAL PIVOTING METHOD: +* +* A = U*D*U' OR A = L*D*L' +* +* WHERE U (OR L) IS A PRODUCT OF PERMUTATION AND UNIT UPPER (LOWER) +* TRIANGULAR MATRICES, U' IS THE TRANSPOSE OF U, AND D IS SYMMETRIC AND +* BLOCK DIAGONAL WITH 1-BY-1 AND 2-BY-2 DIAGONAL BLOCKS. +* +* THIS IS THE UNBLOCKED VERSION OF THE ALGORITHM, CALLING LEVEL 2 BLAS. +* +* ARGUMENTS +* ========= +* +* UPLO (INPUT) CHARACTER*1 +* SPECIFIES WHETHER THE UPPER OR LOWER TRIANGULAR PART OF THE +* SYMMETRIC MATRIX A IS STORED: +* = 'U': UPPER TRIANGULAR +* = 'L': LOWER TRIANGULAR +* +* N (INPUT) INTEGER +* THE ORDER OF THE MATRIX A. N >= 0. +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* ON ENTRY, THE SYMMETRIC MATRIX A. IF UPLO = 'U', THE LEADING +* N-BY-N UPPER TRIANGULAR PART OF A CONTAINS THE UPPER +* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY LOWER +* TRIANGULAR PART OF A IS NOT REFERENCED. IF UPLO = 'L', THE +* LEADING N-BY-N LOWER TRIANGULAR PART OF A CONTAINS THE LOWER +* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY UPPER +* TRIANGULAR PART OF A IS NOT REFERENCED. +* +* ON EXIT, THE BLOCK DIAGONAL MATRIX D AND THE MULTIPLIERS USED +* TO OBTAIN THE FACTOR U OR L (SEE BELOW FOR FURTHER DETAILS). +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N). +* +* IPIV (OUTPUT) INTEGER ARRAY, DIMENSION (N) +* DETAILS OF THE INTERCHANGES AND THE BLOCK STRUCTURE OF D. +* IF IPIV(K) > 0, THEN ROWS AND COLUMNS K AND IPIV(K) WERE +* INTERCHANGED AND D(K,K) IS A 1-BY-1 DIAGONAL BLOCK. +* IF UPLO = 'U' AND IPIV(K) = IPIV(K-1) < 0, THEN ROWS AND +* COLUMNS K-1 AND -IPIV(K) WERE INTERCHANGED AND D(K-1:K,K-1:K) +* IS A 2-BY-2 DIAGONAL BLOCK. IF UPLO = 'L' AND IPIV(K) = +* IPIV(K+1) < 0, THEN ROWS AND COLUMNS K+1 AND -IPIV(K) WERE +* INTERCHANGED AND D(K:K+1,K:K+1) IS A 2-BY-2 DIAGONAL BLOCK. +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -K, THE K-TH ARGUMENT HAD AN ILLEGAL VALUE +* > 0: IF INFO = K, D(K,K) IS EXACTLY ZERO. THE FACTORIZATION +* HAS BEEN COMPLETED, BUT THE BLOCK DIAGONAL MATRIX D IS +* EXACTLY SINGULAR, AND DIVISION BY ZERO WILL OCCUR IF IT +* IS USED TO SOLVE A SYSTEM OF EQUATIONS. +* +* FURTHER DETAILS +* =============== +* +* IF UPLO = 'U', THEN A = U*D*U', WHERE +* U = P(N)*U(N)* ... *P(K)U(K)* ..., +* I.E., U IS A PRODUCT OF TERMS P(K)*U(K), WHERE K DECREASES FROM N TO +* 1 IN STEPS OF 1 OR 2, AND D IS A BLOCK DIAGONAL MATRIX WITH 1-BY-1 +* AND 2-BY-2 DIAGONAL BLOCKS D(K). P(K) IS A PERMUTATION MATRIX AS +* DEFINED BY IPIV(K), AND U(K) IS A UNIT UPPER TRIANGULAR MATRIX, SUCH +* THAT IF THE DIAGONAL BLOCK D(K) IS OF ORDER S (S = 1 OR 2), THEN +* +* ( I V 0 ) K-S +* U(K) = ( 0 I 0 ) S +* ( 0 0 I ) N-K +* K-S S N-K +* +* IF S = 1, D(K) OVERWRITES A(K,K), AND V OVERWRITES A(1:K-1,K). +* IF S = 2, THE UPPER TRIANGLE OF D(K) OVERWRITES A(K-1,K-1), A(K-1,K), +* AND A(K,K), AND V OVERWRITES A(1:K-2,K-1:K). +* +* IF UPLO = 'L', THEN A = L*D*L', WHERE +* L = P(1)*L(1)* ... *P(K)*L(K)* ..., +* I.E., L IS A PRODUCT OF TERMS P(K)*L(K), WHERE K INCREASES FROM 1 TO +* N IN STEPS OF 1 OR 2, AND D IS A BLOCK DIAGONAL MATRIX WITH 1-BY-1 +* AND 2-BY-2 DIAGONAL BLOCKS D(K). P(K) IS A PERMUTATION MATRIX AS +* DEFINED BY IPIV(K), AND L(K) IS A UNIT LOWER TRIANGULAR MATRIX, SUCH +* THAT IF THE DIAGONAL BLOCK D(K) IS OF ORDER S (S = 1 OR 2), THEN +* +* ( I 0 0 ) K-1 +* L(K) = ( 0 I 0 ) S +* ( 0 V I ) N-K-S+1 +* K-1 S N-K-S+1 +* +* IF S = 1, D(K) OVERWRITES A(K,K), AND V OVERWRITES A(K+1:N,K). +* IF S = 2, THE LOWER TRIANGLE OF D(K) OVERWRITES A(K,K), A(K+1,K), +* AND A(K+1,K+1), AND V OVERWRITES A(K+2:N,K:K+1). +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. LOCAL SCALARS .. + LOGICAL UPPER + INTEGER IMAX, JMAX, K, KK, KP, KSTEP + DOUBLE PRECISION ABSAKK, ALPHA, C, COLMAX, R1, R2, ROWMAX, S, T +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + INTEGER IDAMAX + EXTERNAL LSAME, IDAMAX +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLAEV2, DROT, DSCAL, DSWAP, DSYR, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS, MAX, SQRT +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTF2', -INFO ) + RETURN + END IF +* +* INITIALIZE ALPHA FOR USE IN CHOOSING PIVOT BLOCK SIZE. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* + IF( UPPER ) THEN +* +* FACTORIZE A AS U*D*U' USING THE UPPER TRIANGLE OF A +* +* K IS THE MAIN LOOP INDEX, DECREASING FROM N TO 1 IN STEPS OF +* 1 OR 2 +* + K = N + 10 CONTINUE +* +* IF K < 1, EXIT FROM LOOP +* + IF( K.LT.1 ) + $ GO TO 30 + KSTEP = 1 +* +* DETERMINE ROWS AND COLUMNS TO BE INTERCHANGED AND WHETHER +* A 1-BY-1 OR 2-BY-2 PIVOT BLOCK WILL BE USED +* + ABSAKK = ABS( A( K, K ) ) +* +* IMAX IS THE ROW-INDEX OF THE LARGEST OFF-DIAGONAL ELEMENT IN +* COLUMN K, AND COLMAX IS ITS ABSOLUTE VALUE +* + IF( K.GT.1 ) THEN + IMAX = IDAMAX( K-1, A( 1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* COLUMN K IS ZERO: SET INFO AND CONTINUE +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE + IF( ABSAKK.GE.ALPHA*COLMAX ) THEN +* +* NO INTERCHANGE, USE 1-BY-1 PIVOT BLOCK +* + KP = K + ELSE +* +* JMAX IS THE COLUMN-INDEX OF THE LARGEST OFF-DIAGONAL +* ELEMENT IN ROW IMAX, AND ROWMAX IS ITS ABSOLUTE VALUE +* + JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA ) + ROWMAX = ABS( A( IMAX, JMAX ) ) + IF( IMAX.GT.1 ) THEN + JMAX = IDAMAX( IMAX-1, A( 1, IMAX ), 1 ) + ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) + END IF +* + IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN +* +* NO INTERCHANGE, USE 1-BY-1 PIVOT BLOCK +* + KP = K + ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN +* +* INTERCHANGE ROWS AND COLUMNS K AND IMAX, USE 1-BY-1 +* PIVOT BLOCK +* + KP = IMAX + ELSE +* +* INTERCHANGE ROWS AND COLUMNS K-1 AND IMAX, USE 2-BY-2 +* PIVOT BLOCK +* + KP = IMAX + KSTEP = 2 + END IF + END IF +* + KK = K - KSTEP + 1 + IF( KP.NE.KK ) THEN +* +* INTERCHANGE ROWS AND COLUMNS KK AND KP IN THE LEADING +* SUBMATRIX A(1:K,1:K) +* + CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 ) + CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K-1, K ) + A( K-1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + END IF +* +* UPDATE THE LEADING SUBMATRIX +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-BY-1 PIVOT BLOCK D(K): COLUMN K NOW HOLDS +* +* W(K) = U(K)*D(K) +* +* WHERE U(K) IS THE K-TH COLUMN OF U +* +* PERFORM A RANK-1 UPDATE OF A(1:K-1,1:K-1) AS +* +* A := A - U(K)*D(K)*U(K)' = A - W(K)*1/D(K)*W(K)' +* + R1 = ONE / A( K, K ) + CALL DSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA ) +* +* STORE U(K) IN COLUMN K +* + CALL DSCAL( K-1, R1, A( 1, K ), 1 ) + ELSE +* +* 2-BY-2 PIVOT BLOCK D(K): COLUMNS K AND K-1 NOW HOLD +* +* ( W(K-1) W(K) ) = ( U(K-1) U(K) )*D(K) +* +* WHERE U(K) AND U(K-1) ARE THE K-TH AND (K-1)-TH COLUMNS +* OF U +* +* PERFORM A RANK-2 UPDATE OF A(1:K-2,1:K-2) AS +* +* A := A - ( U(K-1) U(K) )*D(K)*( U(K-1) U(K) )' +* = A - ( W(K-1) W(K) )*INV(D(K))*( W(K-1) W(K) )' +* +* CONVERT THIS TO TWO RANK-1 UPDATES BY USING THE EIGEN- +* DECOMPOSITION OF D(K) +* + CALL DLAEV2( A( K-1, K-1 ), A( K-1, K ), A( K, K ), R1, + $ R2, C, S ) + R1 = ONE / R1 + R2 = ONE / R2 + CALL DROT( K-2, A( 1, K-1 ), 1, A( 1, K ), 1, C, S ) + CALL DSYR( UPLO, K-2, -R1, A( 1, K-1 ), 1, A, LDA ) + CALL DSYR( UPLO, K-2, -R2, A( 1, K ), 1, A, LDA ) +* +* STORE U(K) AND U(K-1) IN COLUMNS K AND K-1 +* + CALL DSCAL( K-2, R1, A( 1, K-1 ), 1 ) + CALL DSCAL( K-2, R2, A( 1, K ), 1 ) + CALL DROT( K-2, A( 1, K-1 ), 1, A( 1, K ), 1, C, -S ) + END IF + END IF +* +* STORE DETAILS OF THE INTERCHANGES IN IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -KP + IPIV( K-1 ) = -KP + END IF +* +* DECREASE K AND RETURN TO THE START OF THE MAIN LOOP +* + K = K - KSTEP + GO TO 10 +* + ELSE +* +* FACTORIZE A AS L*D*L' USING THE LOWER TRIANGLE OF A +* +* K IS THE MAIN LOOP INDEX, INCREASING FROM 1 TO N IN STEPS OF +* 1 OR 2 +* + K = 1 + 20 CONTINUE +* +* IF K > N, EXIT FROM LOOP +* + IF( K.GT.N ) + $ GO TO 30 + KSTEP = 1 +* +* DETERMINE ROWS AND COLUMNS TO BE INTERCHANGED AND WHETHER +* A 1-BY-1 OR 2-BY-2 PIVOT BLOCK WILL BE USED +* + ABSAKK = ABS( A( K, K ) ) +* +* IMAX IS THE ROW-INDEX OF THE LARGEST OFF-DIAGONAL ELEMENT IN +* COLUMN K, AND COLMAX IS ITS ABSOLUTE VALUE +* + IF( K.LT.N ) THEN + IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 ) + COLMAX = ABS( A( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* COLUMN K IS ZERO: SET INFO AND CONTINUE +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE + IF( ABSAKK.GE.ALPHA*COLMAX ) THEN +* +* NO INTERCHANGE, USE 1-BY-1 PIVOT BLOCK +* + KP = K + ELSE +* +* JMAX IS THE COLUMN-INDEX OF THE LARGEST OFF-DIAGONAL +* ELEMENT IN ROW IMAX, AND ROWMAX IS ITS ABSOLUTE VALUE +* + JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA ) + ROWMAX = ABS( A( IMAX, JMAX ) ) + IF( IMAX.LT.N ) THEN + JMAX = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 ) + ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) ) + END IF +* + IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN +* +* NO INTERCHANGE, USE 1-BY-1 PIVOT BLOCK +* + KP = K + ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN +* +* INTERCHANGE ROWS AND COLUMNS K AND IMAX, USE 1-BY-1 +* PIVOT BLOCK +* + KP = IMAX + ELSE +* +* INTERCHANGE ROWS AND COLUMNS K+1 AND IMAX, USE 2-BY-2 +* PIVOT BLOCK +* + KP = IMAX + KSTEP = 2 + END IF + END IF +* + KK = K + KSTEP - 1 + IF( KP.NE.KK ) THEN +* +* INTERCHANGE ROWS AND COLUMNS KK AND KP IN THE TRAILING +* SUBMATRIX A(K:N,K:N) +* + IF( KP.LT.N ) + $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 ) + CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ), + $ LDA ) + T = A( KK, KK ) + A( KK, KK ) = A( KP, KP ) + A( KP, KP ) = T + IF( KSTEP.EQ.2 ) THEN + T = A( K+1, K ) + A( K+1, K ) = A( KP, K ) + A( KP, K ) = T + END IF + END IF +* +* UPDATE THE TRAILING SUBMATRIX +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-BY-1 PIVOT BLOCK D(K): COLUMN K NOW HOLDS +* +* W(K) = L(K)*D(K) +* +* WHERE L(K) IS THE K-TH COLUMN OF L +* + IF( K.LT.N ) THEN +* +* PERFORM A RANK-1 UPDATE OF A(K+1:N,K+1:N) AS +* +* A := A - L(K)*D(K)*L(K)' = A - W(K)*(1/D(K))*W(K)' +* + R1 = ONE / A( K, K ) + CALL DSYR( UPLO, N-K, -R1, A( K+1, K ), 1, + $ A( K+1, K+1 ), LDA ) +* +* STORE L(K) IN COLUMN K +* + CALL DSCAL( N-K, R1, A( K+1, K ), 1 ) + END IF + ELSE +* +* 2-BY-2 PIVOT BLOCK D(K): COLUMNS K AND K+1 NOW HOLD +* +* ( W(K) W(K+1) ) = ( L(K) L(K+1) )*D(K) +* +* WHERE L(K) AND L(K+1) ARE THE K-TH AND (K+1)-TH COLUMNS +* OF L +* + IF( K.LT.N-1 ) THEN +* +* PERFORM A RANK-2 UPDATE OF A(K+2:N,K+2:N) AS +* +* A := A - ( L(K) L(K+1) )*D(K)*( L(K) L(K+1) )' +* = A - ( W(K) W(K+1) )*INV(D(K))*( W(K) W(K+1) )' +* +* CONVERT THIS TO TWO RANK-1 UPDATES BY USING THE EIGEN- +* DECOMPOSITION OF D(K) +* + CALL DLAEV2( A( K, K ), A( K+1, K ), A( K+1, K+1 ), + $ R1, R2, C, S ) + R1 = ONE / R1 + R2 = ONE / R2 + CALL DROT( N-K-1, A( K+2, K ), 1, A( K+2, K+1 ), 1, C, + $ S ) + CALL DSYR( UPLO, N-K-1, -R1, A( K+2, K ), 1, + $ A( K+2, K+2 ), LDA ) + CALL DSYR( UPLO, N-K-1, -R2, A( K+2, K+1 ), 1, + $ A( K+2, K+2 ), LDA ) +* +* STORE L(K) AND L(K+1) IN COLUMNS K AND K+1 +* + CALL DSCAL( N-K-1, R1, A( K+2, K ), 1 ) + CALL DSCAL( N-K-1, R2, A( K+2, K+1 ), 1 ) + CALL DROT( N-K-1, A( K+2, K ), 1, A( K+2, K+1 ), 1, C, + $ -S ) + END IF + END IF + END IF +* +* STORE DETAILS OF THE INTERCHANGES IN IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -KP + IPIV( K+1 ) = -KP + END IF +* +* INCREASE K AND RETURN TO THE START OF THE MAIN LOOP +* + K = K + KSTEP + GO TO 20 +* + END IF +* + 30 CONTINUE + RETURN +* +* END OF DSYTF2 +* + END +CUT HERE.......... +CAT > DLASYF.F <<'CUT HERE..........' + SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.0B) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* FEBRUARY 29, 1992 +* +* .. SCALAR ARGUMENTS .. + CHARACTER UPLO + INTEGER INFO, KB, LDA, LDW, N, NB +* .. +* .. ARRAY ARGUMENTS .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), W( LDW, * ) +* .. +* +* PURPOSE +* ======= +* +* DLASYF COMPUTES A PARTIAL FACTORIZATION OF A REAL SYMMETRIC MATRIX A +* USING THE BUNCH-KAUFMAN DIAGONAL PIVOTING METHOD. THE PARTIAL +* FACTORIZATION HAS THE FORM: +* +* A = ( I U12 ) ( A11 0 ) ( I 0 ) IF UPLO = 'U', OR: +* ( 0 U22 ) ( 0 D ) ( U12' U22' ) +* +* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) IF UPLO = 'L' +* ( L21 I ) ( 0 A22 ) ( 0 I ) +* +* WHERE THE ORDER OF D IS AT MOST NB. THE ACTUAL ORDER IS RETURNED IN +* THE ARGUMENT KB, AND IS EITHER NB OR NB-1, OR N IF N <= NB. +* +* DLASYF IS AN AUXILIARY ROUTINE CALLED BY DSYTRF. IT USES BLOCKED CODE +* (CALLING LEVEL 3 BLAS) TO UPDATE THE SUBMATRIX A11 (IF UPLO = 'U') OR +* A22 (IF UPLO = 'L'). +* +* ARGUMENTS +* ========= +* +* UPLO (INPUT) CHARACTER*1 +* SPECIFIES WHETHER THE UPPER OR LOWER TRIANGULAR PART OF THE +* SYMMETRIC MATRIX A IS STORED: +* = 'U': UPPER TRIANGULAR +* = 'L': LOWER TRIANGULAR +* +* N (INPUT) INTEGER +* THE ORDER OF THE MATRIX A. N >= 0. +* +* NB (INPUT) INTEGER +* THE MAXIMUM NUMBER OF COLUMNS OF THE MATRIX A THAT SHOULD BE +* FACTORED. NB SHOULD BE AT LEAST 2 TO ALLOW FOR 2-BY-2 PIVOT +* BLOCKS. +* +* KB (OUTPUT) INTEGER +* THE NUMBER OF COLUMNS OF A THAT WERE ACTUALLY FACTORED. +* KB IS EITHER NB-1 OR NB, OR N IF N <= NB. +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* ON ENTRY, THE SYMMETRIC MATRIX A. IF UPLO = 'U', THE LEADING +* N-BY-N UPPER TRIANGULAR PART OF A CONTAINS THE UPPER +* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY LOWER +* TRIANGULAR PART OF A IS NOT REFERENCED. IF UPLO = 'L', THE +* LEADING N-BY-N LOWER TRIANGULAR PART OF A CONTAINS THE LOWER +* TRIANGULAR PART OF THE MATRIX A, AND THE STRICTLY UPPER +* TRIANGULAR PART OF A IS NOT REFERENCED. +* ON EXIT, A CONTAINS DETAILS OF THE PARTIAL FACTORIZATION. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N). +* +* IPIV (OUTPUT) INTEGER ARRAY, DIMENSION (N) +* DETAILS OF THE INTERCHANGES AND THE BLOCK STRUCTURE OF D. +* IF UPLO = 'U', ONLY THE LAST KB ELEMENTS OF IPIV ARE SET; +* IF UPLO = 'L', ONLY THE FIRST KB ELEMENTS ARE SET. +* +* IF IPIV(K) > 0, THEN ROWS AND COLUMNS K AND IPIV(K) WERE +* INTERCHANGED AND D(K,K) IS A 1-BY-1 DIAGONAL BLOCK. +* IF UPLO = 'U' AND IPIV(K) = IPIV(K-1) < 0, THEN ROWS AND +* COLUMNS K-1 AND -IPIV(K) WERE INTERCHANGED AND D(K-1:K,K-1:K) +* IS A 2-BY-2 DIAGONAL BLOCK. IF UPLO = 'L' AND IPIV(K) = +* IPIV(K+1) < 0, THEN ROWS AND COLUMNS K+1 AND -IPIV(K) WERE +* INTERCHANGED AND D(K:K+1,K:K+1) IS A 2-BY-2 DIAGONAL BLOCK. +* +* W (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (LDW,NB) +* +* LDW (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY W. LDW >= MAX(1,N). +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* > 0: IF INFO = K, D(K,K) IS EXACTLY ZERO. THE FACTORIZATION +* HAS BEEN COMPLETED, BUT THE BLOCK DIAGONAL MATRIX D IS +* EXACTLY SINGULAR. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) + DOUBLE PRECISION EIGHT, SEVTEN + PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP, + $ KSTEP, KW + DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1, + $ ROWMAX, T +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + INTEGER IDAMAX + EXTERNAL LSAME, IDAMAX +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. EXECUTABLE STATEMENTS .. +* + INFO = 0 +* +* INITIALIZE ALPHA FOR USE IN CHOOSING PIVOT BLOCK SIZE. +* + ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT +* + IF( LSAME( UPLO, 'U' ) ) THEN +* +* FACTORIZE THE TRAILING COLUMNS OF A USING THE UPPER TRIANGLE +* OF A AND WORKING BACKWARDS, AND COMPUTE THE MATRIX W = U12*D +* FOR USE IN UPDATING A11 +* +* K IS THE MAIN LOOP INDEX, DECREASING FROM N IN STEPS OF 1 OR 2 +* +* KW IS THE COLUMN OF W WHICH CORRESPONDS TO COLUMN K OF A +* + K = N + 10 CONTINUE + KW = NB + K - N +* +* EXIT FROM LOOP +* + IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 ) + $ GO TO 30 +* +* COPY COLUMN K OF A TO COLUMN KW OF W AND UPDATE IT +* + CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 ) + IF( K.LT.N ) + $ CALL DGEMV( 'NO TRANSPOSE', K, N-K, -ONE, A( 1, K+1 ), LDA, + $ W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 ) +* + KSTEP = 1 +* +* DETERMINE ROWS AND COLUMNS TO BE INTERCHANGED AND WHETHER +* A 1-BY-1 OR 2-BY-2 PIVOT BLOCK WILL BE USED +* + ABSAKK = ABS( W( K, KW ) ) +* +* IMAX IS THE ROW-INDEX OF THE LARGEST OFF-DIAGONAL ELEMENT IN +* COLUMN K, AND COLMAX IS ITS ABSOLUTE VALUE +* + IF( K.GT.1 ) THEN + IMAX = IDAMAX( K-1, W( 1, KW ), 1 ) + COLMAX = ABS( W( IMAX, KW ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* COLUMN K IS ZERO: SET INFO AND CONTINUE +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE + IF( ABSAKK.GE.ALPHA*COLMAX ) THEN +* +* NO INTERCHANGE, USE 1-BY-1 PIVOT BLOCK +* + KP = K + ELSE +* +* COPY COLUMN IMAX TO COLUMN KW-1 OF W AND UPDATE IT +* + CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 ) + CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA, + $ W( IMAX+1, KW-1 ), 1 ) + IF( K.LT.N ) + $ CALL DGEMV( 'NO TRANSPOSE', K, N-K, -ONE, A( 1, K+1 ), + $ LDA, W( IMAX, KW+1 ), LDW, ONE, + $ W( 1, KW-1 ), 1 ) +* +* JMAX IS THE COLUMN-INDEX OF THE LARGEST OFF-DIAGONAL +* ELEMENT IN ROW IMAX, AND ROWMAX IS ITS ABSOLUTE VALUE +* + JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 ) + ROWMAX = ABS( W( JMAX, KW-1 ) ) + IF( IMAX.GT.1 ) THEN + JMAX = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 ) + ROWMAX = MAX( ROWMAX, ABS( W( JMAX, KW-1 ) ) ) + END IF +* + IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN +* +* NO INTERCHANGE, USE 1-BY-1 PIVOT BLOCK +* + KP = K + ELSE IF( ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN +* +* INTERCHANGE ROWS AND COLUMNS K AND IMAX, USE 1-BY-1 +* PIVOT BLOCK +* + KP = IMAX +* +* COPY COLUMN KW-1 OF W TO COLUMN KW +* + CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 ) + ELSE +* +* INTERCHANGE ROWS AND COLUMNS K-1 AND IMAX, USE 2-BY-2 +* PIVOT BLOCK +* + KP = IMAX + KSTEP = 2 + END IF + END IF +* + KK = K - KSTEP + 1 + KKW = NB + KK - N +* +* UPDATED COLUMN KP IS ALREADY STORED IN COLUMN KKW OF W +* + IF( KP.NE.KK ) THEN +* +* COPY NON-UPDATED COLUMN KK TO COLUMN KP +* + A( KP, K ) = A( KK, K ) + CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ), + $ LDA ) + CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 ) +* +* INTERCHANGE ROWS KK AND KP IN LAST KK COLUMNS OF A AND W +* + CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA ) + CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ), + $ LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-BY-1 PIVOT BLOCK D(K): COLUMN KW OF W NOW HOLDS +* +* W(K) = U(K)*D(K) +* +* WHERE U(K) IS THE K-TH COLUMN OF U +* +* STORE U(K) IN COLUMN K OF A +* + CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 ) + R1 = ONE / A( K, K ) + CALL DSCAL( K-1, R1, A( 1, K ), 1 ) + ELSE +* +* 2-BY-2 PIVOT BLOCK D(K): COLUMNS KW AND KW-1 OF W NOW +* HOLD +* +* ( W(K-1) W(K) ) = ( U(K-1) U(K) )*D(K) +* +* WHERE U(K) AND U(K-1) ARE THE K-TH AND (K-1)-TH COLUMNS +* OF U +* + IF( K.GT.2 ) THEN +* +* STORE U(K) AND U(K-1) IN COLUMNS K AND K-1 OF A +* + D21 = W( K-1, KW ) + D11 = W( K, KW ) / D21 + D22 = W( K-1, KW-1 ) / D21 + T = ONE / ( D11*D22-ONE ) + D21 = T / D21 + DO 20 J = 1, K - 2 + A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) ) + A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) ) + 20 CONTINUE + END IF +* +* COPY D(K) TO A +* + A( K-1, K-1 ) = W( K-1, KW-1 ) + A( K-1, K ) = W( K-1, KW ) + A( K, K ) = W( K, KW ) + END IF + END IF +* +* STORE DETAILS OF THE INTERCHANGES IN IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -KP + IPIV( K-1 ) = -KP + END IF +* +* DECREASE K AND RETURN TO THE START OF THE MAIN LOOP +* + K = K - KSTEP + GO TO 10 +* + 30 CONTINUE +* +* UPDATE THE UPPER TRIANGLE OF A11 (= A(1:K,1:K)) AS +* +* A11 := A11 - U12*D*U12' = A11 - U12*W' +* +* COMPUTING BLOCKS OF NB COLUMNS AT A TIME +* + DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB + JB = MIN( NB, K-J+1 ) +* +* UPDATE THE UPPER TRIANGLE OF THE DIAGONAL BLOCK +* + DO 40 JJ = J, J + JB - 1 + CALL DGEMV( 'NO TRANSPOSE', JJ-J+1, N-K, -ONE, + $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE, + $ A( J, JJ ), 1 ) + 40 CONTINUE +* +* UPDATE THE RECTANGULAR SUPERDIAGONAL BLOCK +* + CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', J-1, JB, N-K, -ONE, + $ A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE, + $ A( 1, J ), LDA ) + 50 CONTINUE +* +* PUT U12 IN STANDARD FORM BY PARTIALLY UNDOING THE INTERCHANGES +* IN COLUMNS K+1:N +* + J = K + 1 + 60 CONTINUE + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP + J = J + 1 + END IF + J = J + 1 + IF( JP.NE.JJ .AND. J.LE.N ) + $ CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA ) + IF( J.LE.N ) + $ GO TO 60 +* +* SET KB TO THE NUMBER OF COLUMNS FACTORIZED +* + KB = N - K +* + ELSE +* +* FACTORIZE THE LEADING COLUMNS OF A USING THE LOWER TRIANGLE +* OF A AND WORKING FORWARDS, AND COMPUTE THE MATRIX W = L21*D +* FOR USE IN UPDATING A22 +* +* K IS THE MAIN LOOP INDEX, INCREASING FROM 1 IN STEPS OF 1 OR 2 +* + K = 1 + 70 CONTINUE +* +* EXIT FROM LOOP +* + IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N ) + $ GO TO 90 +* +* COPY COLUMN K OF A TO COLUMN K OF W AND UPDATE IT +* + CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 ) + CALL DGEMV( 'NO TRANSPOSE', N-K+1, K-1, -ONE, A( K, 1 ), LDA, + $ W( K, 1 ), LDW, ONE, W( K, K ), 1 ) +* + KSTEP = 1 +* +* DETERMINE ROWS AND COLUMNS TO BE INTERCHANGED AND WHETHER +* A 1-BY-1 OR 2-BY-2 PIVOT BLOCK WILL BE USED +* + ABSAKK = ABS( W( K, K ) ) +* +* IMAX IS THE ROW-INDEX OF THE LARGEST OFF-DIAGONAL ELEMENT IN +* COLUMN K, AND COLMAX IS ITS ABSOLUTE VALUE +* + IF( K.LT.N ) THEN + IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 ) + COLMAX = ABS( W( IMAX, K ) ) + ELSE + COLMAX = ZERO + END IF +* + IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN +* +* COLUMN K IS ZERO: SET INFO AND CONTINUE +* + IF( INFO.EQ.0 ) + $ INFO = K + KP = K + ELSE + IF( ABSAKK.GE.ALPHA*COLMAX ) THEN +* +* NO INTERCHANGE, USE 1-BY-1 PIVOT BLOCK +* + KP = K + ELSE +* +* COPY COLUMN IMAX TO COLUMN K+1 OF W AND UPDATE IT +* + CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 ) + CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ), + $ 1 ) + CALL DGEMV( 'NO TRANSPOSE', N-K+1, K-1, -ONE, A( K, 1 ), + $ LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 ) +* +* JMAX IS THE COLUMN-INDEX OF THE LARGEST OFF-DIAGONAL +* ELEMENT IN ROW IMAX, AND ROWMAX IS ITS ABSOLUTE VALUE +* + JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 ) + ROWMAX = ABS( W( JMAX, K+1 ) ) + IF( IMAX.LT.N ) THEN + JMAX = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 ) + ROWMAX = MAX( ROWMAX, ABS( W( JMAX, K+1 ) ) ) + END IF +* + IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN +* +* NO INTERCHANGE, USE 1-BY-1 PIVOT BLOCK +* + KP = K + ELSE IF( ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN +* +* INTERCHANGE ROWS AND COLUMNS K AND IMAX, USE 1-BY-1 +* PIVOT BLOCK +* + KP = IMAX +* +* COPY COLUMN K+1 OF W TO COLUMN K +* + CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 ) + ELSE +* +* INTERCHANGE ROWS AND COLUMNS K+1 AND IMAX, USE 2-BY-2 +* PIVOT BLOCK +* + KP = IMAX + KSTEP = 2 + END IF + END IF +* + KK = K + KSTEP - 1 +* +* UPDATED COLUMN KP IS ALREADY STORED IN COLUMN KK OF W +* + IF( KP.NE.KK ) THEN +* +* COPY NON-UPDATED COLUMN KK TO COLUMN KP +* + A( KP, K ) = A( KK, K ) + CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA ) + CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 ) +* +* INTERCHANGE ROWS KK AND KP IN FIRST KK COLUMNS OF A AND W +* + CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA ) + CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW ) + END IF +* + IF( KSTEP.EQ.1 ) THEN +* +* 1-BY-1 PIVOT BLOCK D(K): COLUMN K OF W NOW HOLDS +* +* W(K) = L(K)*D(K) +* +* WHERE L(K) IS THE K-TH COLUMN OF L +* +* STORE L(K) IN COLUMN K OF A +* + CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 ) + IF( K.LT.N ) THEN + R1 = ONE / A( K, K ) + CALL DSCAL( N-K, R1, A( K+1, K ), 1 ) + END IF + ELSE +* +* 2-BY-2 PIVOT BLOCK D(K): COLUMNS K AND K+1 OF W NOW HOLD +* +* ( W(K) W(K+1) ) = ( L(K) L(K+1) )*D(K) +* +* WHERE L(K) AND L(K+1) ARE THE K-TH AND (K+1)-TH COLUMNS +* OF L +* + IF( K.LT.N-1 ) THEN +* +* STORE L(K) AND L(K+1) IN COLUMNS K AND K+1 OF A +* + D21 = W( K+1, K ) + D11 = W( K+1, K+1 ) / D21 + D22 = W( K, K ) / D21 + T = ONE / ( D11*D22-ONE ) + D21 = T / D21 + DO 80 J = K + 2, N + A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) ) + A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) ) + 80 CONTINUE + END IF +* +* COPY D(K) TO A +* + A( K, K ) = W( K, K ) + A( K+1, K ) = W( K+1, K ) + A( K+1, K+1 ) = W( K+1, K+1 ) + END IF + END IF +* +* STORE DETAILS OF THE INTERCHANGES IN IPIV +* + IF( KSTEP.EQ.1 ) THEN + IPIV( K ) = KP + ELSE + IPIV( K ) = -KP + IPIV( K+1 ) = -KP + END IF +* +* INCREASE K AND RETURN TO THE START OF THE MAIN LOOP +* + K = K + KSTEP + GO TO 70 +* + 90 CONTINUE +* +* UPDATE THE LOWER TRIANGLE OF A22 (= A(K:N,K:N)) AS +* +* A22 := A22 - L21*D*L21' = A22 - L21*W' +* +* COMPUTING BLOCKS OF NB COLUMNS AT A TIME +* + DO 110 J = K, N, NB + JB = MIN( NB, N-J+1 ) +* +* UPDATE THE LOWER TRIANGLE OF THE DIAGONAL BLOCK +* + DO 100 JJ = J, J + JB - 1 + CALL DGEMV( 'NO TRANSPOSE', J+JB-JJ, K-1, -ONE, + $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE, + $ A( JJ, JJ ), 1 ) + 100 CONTINUE +* +* UPDATE THE RECTANGULAR SUBDIAGONAL BLOCK +* + IF( J+JB.LE.N ) + $ CALL DGEMM( 'NO TRANSPOSE', 'TRANSPOSE', N-J-JB+1, JB, + $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW, + $ ONE, A( J+JB, J ), LDA ) + 110 CONTINUE +* +* PUT L21 IN STANDARD FORM BY PARTIALLY UNDOING THE INTERCHANGES +* IN COLUMNS 1:K-1 +* + J = K - 1 + 120 CONTINUE + JJ = J + JP = IPIV( J ) + IF( JP.LT.0 ) THEN + JP = -JP + J = J - 1 + END IF + J = J - 1 + IF( JP.NE.JJ .AND. J.GE.1 ) + $ CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA ) + IF( J.GE.1 ) + $ GO TO 120 +* +* SET KB TO THE NUMBER OF COLUMNS FACTORIZED +* + KB = K - 1 +* + END IF + RETURN +* +* END OF DLASYF +* + END +CUT HERE.......... +C --------------------- BELOW IS DSYTRI ------------------ + SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.0B) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. ARRAY ARGUMENTS .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), WORK( * ) +* .. +* +* PURPOSE +* ======= +* +* DSYTRI COMPUTES THE INVERSE OF A REAL SYMMETRIC INDEFINITE MATRIX +* A USING THE FACTORIZATION A = U*D*U' OR A = L*D*L' COMPUTED BY +* DSYTRF. +* +* ARGUMENTS +* ========= +* +* UPLO (INPUT) CHARACTER*1 +* SPECIFIES WHETHER THE DETAILS OF THE FACTORIZATION ARE STORED +* AS AN UPPER OR LOWER TRIANGULAR MATRIX. +* = 'U': UPPER TRIANGULAR (FORM IS A = U*D*U') +* = 'L': LOWER TRIANGULAR (FORM IS A = L*D*L') +* +* N (INPUT) INTEGER +* THE ORDER OF THE MATRIX A. N >= 0. +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* ON ENTRY, THE BLOCK DIAGONAL MATRIX D AND THE MULTIPLIERS +* USED TO OBTAIN THE FACTOR U OR L AS COMPUTED BY DSYTRF. +* +* ON EXIT, IF INFO = 0, THE (SYMMETRIC) INVERSE OF THE ORIGINAL +* MATRIX. IF UPLO = 'U', THE UPPER TRIANGULAR PART OF THE +* INVERSE IS FORMED AND THE PART OF A BELOW THE DIAGONAL IS NOT +* REFERENCED; IF UPLO = 'L' THE LOWER TRIANGULAR PART OF THE +* INVERSE IS FORMED AND THE PART OF A ABOVE THE DIAGONAL IS +* NOT REFERENCED. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N). +* +* IPIV (INPUT) INTEGER ARRAY, DIMENSION (N) +* DETAILS OF THE INTERCHANGES AND THE BLOCK STRUCTURE OF D +* AS DETERMINED BY DSYTRF. +* +* WORK (WORKSPACE) DOUBLE PRECISION ARRAY, DIMENSION (N) +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -K, THE K-TH ARGUMENT HAD AN ILLEGAL VALUE +* > 0: IF INFO = K, D(K,K) = 0; THE MATRIX IS SINGULAR AND ITS +* INVERSE COULD NOT BE COMPUTED. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. LOCAL SCALARS .. + LOGICAL UPPER + INTEGER K, KP, KSTEP + DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DCOPY, DSWAP, DSYMV, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC ABS, MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSYTRI', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( N.EQ.0 ) + $ RETURN +* +* CHECK THAT THE DIAGONAL MATRIX D IS NONSINGULAR. +* + IF( UPPER ) THEN +* +* UPPER TRIANGULAR STORAGE: EXAMINE D FROM BOTTOM TO TOP +* + DO 10 INFO = N, 1, -1 + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) + $ RETURN + 10 CONTINUE + ELSE +* +* LOWER TRIANGULAR STORAGE: EXAMINE D FROM TOP TO BOTTOM. +* + DO 20 INFO = 1, N + IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO ) + $ RETURN + 20 CONTINUE + END IF + INFO = 0 +* + IF( UPPER ) THEN +* +* COMPUTE INV(A) FROM THE FACTORIZATION A = U*D*U'. +* +* K IS THE MAIN LOOP INDEX, INCREASING FROM 1 TO N IN STEPS OF +* 1 OR 2, DEPENDING ON THE SIZE OF THE DIAGONAL BLOCKS. +* + K = 1 + 30 CONTINUE +* +* IF K > N, EXIT FROM LOOP. +* + IF( K.GT.N ) + $ GO TO 40 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 X 1 DIAGONAL BLOCK +* +* INVERT THE DIAGONAL BLOCK. +* + A( K, K ) = ONE / A( K, K ) +* +* COMPUTE COLUMN K OF THE INVERSE. +* + IF( K.GT.1 ) THEN + CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, + $ A( 1, K ), 1 ) + A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), + $ 1 ) + END IF + KSTEP = 1 + ELSE +* +* 2 X 2 DIAGONAL BLOCK +* +* INVERT THE DIAGONAL BLOCK. +* + T = ABS( A( K, K+1 ) ) + AK = A( K, K ) / T + AKP1 = A( K+1, K+1 ) / T + AKKP1 = A( K, K+1 ) / T + D = T*( AK*AKP1-ONE ) + A( K, K ) = AKP1 / D + A( K+1, K+1 ) = AK / D + A( K, K+1 ) = -AKKP1 / D +* +* COMPUTE COLUMNS K AND K+1 OF THE INVERSE. +* + IF( K.GT.1 ) THEN + CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 ) + CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, + $ A( 1, K ), 1 ) + A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ), + $ 1 ) + A( K, K+1 ) = A( K, K+1 ) - + $ DDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 ) + CALL DCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 ) + CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO, + $ A( 1, K+1 ), 1 ) + A( K+1, K+1 ) = A( K+1, K+1 ) - + $ DDOT( K-1, WORK, 1, A( 1, K+1 ), 1 ) + END IF + KSTEP = 2 + END IF +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN +* +* INTERCHANGE ROWS AND COLUMNS K AND KP IN THE LEADING +* SUBMATRIX A(1:K+1,1:K+1) +* + CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 ) + CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + IF( KSTEP.EQ.2 ) THEN + TEMP = A( K, K+1 ) + A( K, K+1 ) = A( KP, K+1 ) + A( KP, K+1 ) = TEMP + END IF + END IF +* + K = K + KSTEP + GO TO 30 + 40 CONTINUE +* + ELSE +* +* COMPUTE INV(A) FROM THE FACTORIZATION A = L*D*L'. +* +* K IS THE MAIN LOOP INDEX, INCREASING FROM 1 TO N IN STEPS OF +* 1 OR 2, DEPENDING ON THE SIZE OF THE DIAGONAL BLOCKS. +* + K = N + 50 CONTINUE +* +* IF K < 1, EXIT FROM LOOP. +* + IF( K.LT.1 ) + $ GO TO 60 +* + IF( IPIV( K ).GT.0 ) THEN +* +* 1 X 1 DIAGONAL BLOCK +* +* INVERT THE DIAGONAL BLOCK. +* + A( K, K ) = ONE / A( K, K ) +* +* COMPUTE COLUMN K OF THE INVERSE. +* + IF( K.LT.N ) THEN + CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, + $ ZERO, A( K+1, K ), 1 ) + A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), + $ 1 ) + END IF + KSTEP = 1 + ELSE +* +* 2 X 2 DIAGONAL BLOCK +* +* INVERT THE DIAGONAL BLOCK. +* + T = ABS( A( K, K-1 ) ) + AK = A( K-1, K-1 ) / T + AKP1 = A( K, K ) / T + AKKP1 = A( K, K-1 ) / T + D = T*( AK*AKP1-ONE ) + A( K-1, K-1 ) = AKP1 / D + A( K, K ) = AK / D + A( K, K-1 ) = -AKKP1 / D +* +* COMPUTE COLUMNS K-1 AND K OF THE INVERSE. +* + IF( K.LT.N ) THEN + CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 ) + CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, + $ ZERO, A( K+1, K ), 1 ) + A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ), + $ 1 ) + A( K, K-1 ) = A( K, K-1 ) - + $ DDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ), + $ 1 ) + CALL DCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 ) + CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1, + $ ZERO, A( K+1, K-1 ), 1 ) + A( K-1, K-1 ) = A( K-1, K-1 ) - + $ DDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 ) + END IF + KSTEP = 2 + END IF +* + KP = ABS( IPIV( K ) ) + IF( KP.NE.K ) THEN +* +* INTERCHANGE ROWS AND COLUMNS K AND KP IN THE TRAILING +* SUBMATRIX A(K-1:N,K-1:N) +* + IF( KP.LT.N ) + $ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 ) + CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA ) + TEMP = A( K, K ) + A( K, K ) = A( KP, KP ) + A( KP, KP ) = TEMP + IF( KSTEP.EQ.2 ) THEN + TEMP = A( K, K-1 ) + A( K, K-1 ) = A( KP, K-1 ) + A( KP, K-1 ) = TEMP + END IF + END IF +* + K = K - KSTEP + GO TO 50 + 60 CONTINUE + END IF +* + RETURN +* +* END OF DSYTRI +* + END + +C ------------------ BELOW IS DGESV ------------------------ + SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK DRIVER ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* MARCH 31, 1993 +* +* .. SCALAR ARGUMENTS .. + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. ARRAY ARGUMENTS .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* PURPOSE +* ======= +* +* DGESV COMPUTES THE SOLUTION TO A REAL SYSTEM OF LINEAR EQUATIONS +* A * X = B, +* WHERE A IS AN N-BY-N MATRIX AND X AND B ARE N-BY-NRHS MATRICES. +* +* THE LU DECOMPOSITION WITH PARTIAL PIVOTING AND ROW INTERCHANGES IS +* USED TO FACTOR A AS +* A = P * L * U, +* WHERE P IS A PERMUTATION MATRIX, L IS UNIT LOWER TRIANGULAR, AND U IS +* UPPER TRIANGULAR. THE FACTORED FORM OF A IS THEN USED TO SOLVE THE +* SYSTEM OF EQUATIONS A * X = B. +* +* ARGUMENTS +* ========= +* +* N (INPUT) INTEGER +* THE NUMBER OF LINEAR EQUATIONS, I.E., THE ORDER OF THE +* MATRIX A. N >= 0. +* +* NRHS (INPUT) INTEGER +* THE NUMBER OF RIGHT HAND SIDES, I.E., THE NUMBER OF COLUMNS +* OF THE MATRIX B. NRHS >= 0. +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* ON ENTRY, THE N-BY-N COEFFICIENT MATRIX A. +* ON EXIT, THE FACTORS L AND U FROM THE FACTORIZATION +* A = P*L*U; THE UNIT DIAGONAL ELEMENTS OF L ARE NOT STORED. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N). +* +* IPIV (OUTPUT) INTEGER ARRAY, DIMENSION (N) +* THE PIVOT INDICES THAT DEFINE THE PERMUTATION MATRIX P; +* ROW I OF THE MATRIX WAS INTERCHANGED WITH ROW IPIV(I). +* +* B (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDB,NRHS) +* ON ENTRY, THE N-BY-NRHS MATRIX OF RIGHT HAND SIDE MATRIX B. +* ON EXIT, IF INFO = 0, THE N-BY-NRHS SOLUTION MATRIX X. +* +* LDB (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY B. LDB >= MAX(1,N). +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE +* > 0: IF INFO = I, U(I,I) IS EXACTLY ZERO. THE FACTORIZATION +* HAS BEEN COMPLETED, BUT THE FACTOR U IS EXACTLY +* SINGULAR, SO THE SOLUTION COULD NOT BE COMPUTED. +* +* ===================================================================== +* +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DGETRF, DGETRS, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGESV ', -INFO ) + RETURN + END IF +* +* COMPUTE THE LU FACTORIZATION OF A. +* + CALL DGETRF( N, N, A, LDA, IPIV, INFO ) + IF( INFO.EQ.0 ) THEN +* +* SOLVE THE SYSTEM A*X = B, OVERWRITING B WITH X. +* + CALL DGETRS( 'NO TRANSPOSE', N, NRHS, A, LDA, IPIV, B, LDB, + $ INFO ) + END IF + RETURN +* +* END OF DGESV +* + END +CUT HERE............ +CAT > DGETRS.F <<'CUT HERE............' + SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* MARCH 31, 1993 +* +* .. SCALAR ARGUMENTS .. + CHARACTER TRANS + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. ARRAY ARGUMENTS .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* PURPOSE +* ======= +* +* DGETRS SOLVES A SYSTEM OF LINEAR EQUATIONS +* A * X = B OR A' * X = B +* WITH A GENERAL N-BY-N MATRIX A USING THE LU FACTORIZATION COMPUTED +* BY DGETRF. +* +* ARGUMENTS +* ========= +* +* TRANS (INPUT) CHARACTER*1 +* SPECIFIES THE FORM OF THE SYSTEM OF EQUATIONS: +* = 'N': A * X = B (NO TRANSPOSE) +* = 'T': A'* X = B (TRANSPOSE) +* = 'C': A'* X = B (CONJUGATE TRANSPOSE = TRANSPOSE) +* +* N (INPUT) INTEGER +* THE ORDER OF THE MATRIX A. N >= 0. +* +* NRHS (INPUT) INTEGER +* THE NUMBER OF RIGHT HAND SIDES, I.E., THE NUMBER OF COLUMNS +* OF THE MATRIX B. NRHS >= 0. +* +* A (INPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* THE FACTORS L AND U FROM THE FACTORIZATION A = P*L*U +* AS COMPUTED BY DGETRF. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,N). +* +* IPIV (INPUT) INTEGER ARRAY, DIMENSION (N) +* THE PIVOT INDICES FROM DGETRF; FOR 1<=I<=N, ROW I OF THE +* MATRIX WAS INTERCHANGED WITH ROW IPIV(I). +* +* B (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDB,NRHS) +* ON ENTRY, THE RIGHT HAND SIDE MATRIX B. +* ON EXIT, THE SOLUTION MATRIX X. +* +* LDB (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY B. LDB >= MAX(1,N). +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. LOCAL SCALARS .. + LOGICAL NOTRAN +* .. +* .. EXTERNAL FUNCTIONS .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DLASWP, DTRSM, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + NOTRAN = LSAME( TRANS, 'N' ) + IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. + $ LSAME( TRANS, 'C' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -8 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETRS', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( NOTRAN ) THEN +* +* SOLVE A * X = B. +* +* APPLY ROW INTERCHANGES TO THE RIGHT HAND SIDES. +* + CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) +* +* SOLVE L*X = B, OVERWRITING B WITH X. +* + CALL DTRSM( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* SOLVE U*X = B, OVERWRITING B WITH X. +* + CALL DTRSM( 'LEFT', 'UPPER', 'NO TRANSPOSE', 'NON-UNIT', N, + $ NRHS, ONE, A, LDA, B, LDB ) + ELSE +* +* SOLVE A' * X = B. +* +* SOLVE U'*X = B, OVERWRITING B WITH X. +* + CALL DTRSM( 'LEFT', 'UPPER', 'TRANSPOSE', 'NON-UNIT', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* SOLVE L'*X = B, OVERWRITING B WITH X. +* + CALL DTRSM( 'LEFT', 'LOWER', 'TRANSPOSE', 'UNIT', N, NRHS, ONE, + $ A, LDA, B, LDB ) +* +* APPLY ROW INTERCHANGES TO THE SOLUTION VECTORS. +* + CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) + END IF +* + RETURN +* +* END OF DGETRS +* + END +CUT HERE............ +CAT > DGETRF.F <<'CUT HERE............' + SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* MARCH 31, 1993 +* +* .. SCALAR ARGUMENTS .. + INTEGER INFO, LDA, M, N +* .. +* .. ARRAY ARGUMENTS .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* PURPOSE +* ======= +* +* DGETRF COMPUTES AN LU FACTORIZATION OF A GENERAL M-BY-N MATRIX A +* USING PARTIAL PIVOTING WITH ROW INTERCHANGES. +* +* THE FACTORIZATION HAS THE FORM +* A = P * L * U +* WHERE P IS A PERMUTATION MATRIX, L IS LOWER TRIANGULAR WITH UNIT +* DIAGONAL ELEMENTS (LOWER TRAPEZOIDAL IF M > N), AND U IS UPPER +* TRIANGULAR (UPPER TRAPEZOIDAL IF M < N). +* +* THIS IS THE RIGHT-LOOKING LEVEL 3 BLAS VERSION OF THE ALGORITHM. +* +* ARGUMENTS +* ========= +* +* M (INPUT) INTEGER +* THE NUMBER OF ROWS OF THE MATRIX A. M >= 0. +* +* N (INPUT) INTEGER +* THE NUMBER OF COLUMNS OF THE MATRIX A. N >= 0. +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* ON ENTRY, THE M-BY-N MATRIX TO BE FACTORED. +* ON EXIT, THE FACTORS L AND U FROM THE FACTORIZATION +* A = P*L*U; THE UNIT DIAGONAL ELEMENTS OF L ARE NOT STORED. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,M). +* +* IPIV (OUTPUT) INTEGER ARRAY, DIMENSION (MIN(M,N)) +* THE PIVOT INDICES; FOR 1 <= I <= MIN(M,N), ROW I OF THE +* MATRIX WAS INTERCHANGED WITH ROW IPIV(I). +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -I, THE I-TH ARGUMENT HAD AN ILLEGAL VALUE +* > 0: IF INFO = I, U(I,I) IS EXACTLY ZERO. THE FACTORIZATION +* HAS BEEN COMPLETED, BUT THE FACTOR U IS EXACTLY +* SINGULAR, AND DIVISION BY ZERO WILL OCCUR IF IT IS USED +* TO SOLVE A SYSTEM OF EQUATIONS. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER I, IINFO, J, JB, NB +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA +* .. +* .. EXTERNAL FUNCTIONS .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETRF', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* +* DETERMINE THE BLOCK SIZE FOR THIS ENVIRONMENT. +* + NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) + IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN +* +* USE UNBLOCKED CODE. +* + CALL DGETF2( M, N, A, LDA, IPIV, INFO ) + ELSE +* +* USE BLOCKED CODE. +* + DO 20 J = 1, MIN( M, N ), NB + JB = MIN( MIN( M, N )-J+1, NB ) +* +* FACTOR DIAGONAL AND SUBDIAGONAL BLOCKS AND TEST FOR EXACT +* SINGULARITY. +* + CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) +* +* ADJUST INFO AND THE PIVOT INDICES. +* + IF( INFO.EQ.0 .AND. IINFO.GT.0 ) + $ INFO = IINFO + J - 1 + DO 10 I = J, MIN( M, J+JB-1 ) + IPIV( I ) = J - 1 + IPIV( I ) + 10 CONTINUE +* +* APPLY INTERCHANGES TO COLUMNS 1:J-1. +* + CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) +* + IF( J+JB.LE.N ) THEN +* +* APPLY INTERCHANGES TO COLUMNS J+JB:N. +* + CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, + $ IPIV, 1 ) +* +* COMPUTE BLOCK ROW OF U. +* + CALL DTRSM( 'LEFT', 'LOWER', 'NO TRANSPOSE', 'UNIT', JB, + $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), + $ LDA ) + IF( J+JB.LE.M ) THEN +* +* UPDATE TRAILING SUBMATRIX. +* + CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', M-J-JB+1, + $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, + $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), + $ LDA ) + END IF + END IF + 20 CONTINUE + END IF + RETURN +* +* END OF DGETRF +* + END +CUT HERE............ +CAT > DLASWP.F <<'CUT HERE............' + SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) +* +* -- LAPACK AUXILIARY ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* OCTOBER 31, 1992 +* +* .. SCALAR ARGUMENTS .. + INTEGER INCX, K1, K2, LDA, N +* .. +* .. ARRAY ARGUMENTS .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* PURPOSE +* ======= +* +* DLASWP PERFORMS A SERIES OF ROW INTERCHANGES ON THE MATRIX A. +* ONE ROW INTERCHANGE IS INITIATED FOR EACH OF ROWS K1 THROUGH K2 OF A. +* +* ARGUMENTS +* ========= +* +* N (INPUT) INTEGER +* THE NUMBER OF COLUMNS OF THE MATRIX A. +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* ON ENTRY, THE MATRIX OF COLUMN DIMENSION N TO WHICH THE ROW +* INTERCHANGES WILL BE APPLIED. +* ON EXIT, THE PERMUTED MATRIX. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. +* +* K1 (INPUT) INTEGER +* THE FIRST ELEMENT OF IPIV FOR WHICH A ROW INTERCHANGE WILL +* BE DONE. +* +* K2 (INPUT) INTEGER +* THE LAST ELEMENT OF IPIV FOR WHICH A ROW INTERCHANGE WILL +* BE DONE. +* +* IPIV (INPUT) INTEGER ARRAY, DIMENSION (M*ABS(INCX)) +* THE VECTOR OF PIVOT INDICES. ONLY THE ELEMENTS IN POSITIONS +* K1 THROUGH K2 OF IPIV ARE ACCESSED. +* IPIV(K) = L IMPLIES ROWS K AND L ARE TO BE INTERCHANGED. +* +* INCX (INPUT) INTEGER +* THE INCREMENT BETWEEN SUCCESSIVE VALUES OF IPIV. IF IPIV +* IS NEGATIVE, THE PIVOTS ARE APPLIED IN REVERSE ORDER. +* +* ===================================================================== +* +* .. LOCAL SCALARS .. + INTEGER I, IP, IX +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DSWAP +* .. +* .. EXECUTABLE STATEMENTS .. +* +* INTERCHANGE ROW I WITH ROW IPIV(I) FOR EACH OF ROWS K1 THROUGH K2. +* + IF( INCX.EQ.0 ) + $ RETURN + IF( INCX.GT.0 ) THEN + IX = K1 + ELSE + IX = 1 + ( 1-K2 )*INCX + END IF + IF( INCX.EQ.1 ) THEN + DO 10 I = K1, K2 + IP = IPIV( I ) + IF( IP.NE.I ) + $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) + 10 CONTINUE + ELSE IF( INCX.GT.1 ) THEN + DO 20 I = K1, K2 + IP = IPIV( IX ) + IF( IP.NE.I ) + $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) + IX = IX + INCX + 20 CONTINUE + ELSE IF( INCX.LT.0 ) THEN + DO 30 I = K2, K1, -1 + IP = IPIV( IX ) + IF( IP.NE.I ) + $ CALL DSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA ) + IX = IX + INCX + 30 CONTINUE + END IF +* + RETURN +* +* END OF DLASWP +* + END +CUT HERE............ +CAT > DGETF2.F <<'CUT HERE............' + SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) +* +* -- LAPACK ROUTINE (VERSION 1.1) -- +* UNIV. OF TENNESSEE, UNIV. OF CALIFORNIA BERKELEY, NAG LTD., +* COURANT INSTITUTE, ARGONNE NATIONAL LAB, AND RICE UNIVERSITY +* JUNE 30, 1992 +* +* .. SCALAR ARGUMENTS .. + INTEGER INFO, LDA, M, N +* .. +* .. ARRAY ARGUMENTS .. + INTEGER IPIV( * ) + DOUBLE PRECISION A( LDA, * ) +* .. +* +* PURPOSE +* ======= +* +* DGETF2 COMPUTES AN LU FACTORIZATION OF A GENERAL M-BY-N MATRIX A +* USING PARTIAL PIVOTING WITH ROW INTERCHANGES. +* +* THE FACTORIZATION HAS THE FORM +* A = P * L * U +* WHERE P IS A PERMUTATION MATRIX, L IS LOWER TRIANGULAR WITH UNIT +* DIAGONAL ELEMENTS (LOWER TRAPEZOIDAL IF M > N), AND U IS UPPER +* TRIANGULAR (UPPER TRAPEZOIDAL IF M < N). +* +* THIS IS THE RIGHT-LOOKING LEVEL 2 BLAS VERSION OF THE ALGORITHM. +* +* ARGUMENTS +* ========= +* +* M (INPUT) INTEGER +* THE NUMBER OF ROWS OF THE MATRIX A. M >= 0. +* +* N (INPUT) INTEGER +* THE NUMBER OF COLUMNS OF THE MATRIX A. N >= 0. +* +* A (INPUT/OUTPUT) DOUBLE PRECISION ARRAY, DIMENSION (LDA,N) +* ON ENTRY, THE M BY N MATRIX TO BE FACTORED. +* ON EXIT, THE FACTORS L AND U FROM THE FACTORIZATION +* A = P*L*U; THE UNIT DIAGONAL ELEMENTS OF L ARE NOT STORED. +* +* LDA (INPUT) INTEGER +* THE LEADING DIMENSION OF THE ARRAY A. LDA >= MAX(1,M). +* +* IPIV (OUTPUT) INTEGER ARRAY, DIMENSION (MIN(M,N)) +* THE PIVOT INDICES; FOR 1 <= I <= MIN(M,N), ROW I OF THE +* MATRIX WAS INTERCHANGED WITH ROW IPIV(I). +* +* INFO (OUTPUT) INTEGER +* = 0: SUCCESSFUL EXIT +* < 0: IF INFO = -K, THE K-TH ARGUMENT HAD AN ILLEGAL VALUE +* > 0: IF INFO = K, U(K,K) IS EXACTLY ZERO. THE FACTORIZATION +* HAS BEEN COMPLETED, BUT THE FACTOR U IS EXACTLY +* SINGULAR, AND DIVISION BY ZERO WILL OCCUR IF IT IS USED +* TO SOLVE A SYSTEM OF EQUATIONS. +* +* ===================================================================== +* +* .. PARAMETERS .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. LOCAL SCALARS .. + INTEGER J, JP +* .. +* .. EXTERNAL FUNCTIONS .. + INTEGER IDAMAX + EXTERNAL IDAMAX +* .. +* .. EXTERNAL SUBROUTINES .. + EXTERNAL DGER, DSCAL, DSWAP, XERBLA +* .. +* .. INTRINSIC FUNCTIONS .. + INTRINSIC MAX, MIN +* .. +* .. EXECUTABLE STATEMENTS .. +* +* TEST THE INPUT PARAMETERS. +* + INFO = 0 + IF( M.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, M ) ) THEN + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DGETF2', -INFO ) + RETURN + END IF +* +* QUICK RETURN IF POSSIBLE +* + IF( M.EQ.0 .OR. N.EQ.0 ) + $ RETURN +* + DO 10 J = 1, MIN( M, N ) +* +* FIND PIVOT AND TEST FOR SINGULARITY. +* + JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) + IPIV( J ) = JP + IF( A( JP, J ).NE.ZERO ) THEN +* +* APPLY THE INTERCHANGE TO COLUMNS 1:N. +* + IF( JP.NE.J ) + $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) +* +* COMPUTE ELEMENTS J+1:M OF J-TH COLUMN. +* + IF( J.LT.M ) + $ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) +* + ELSE IF( INFO.EQ.0 ) THEN +* + INFO = J + END IF +* + IF( J.LT.MIN( M, N ) ) THEN +* +* UPDATE TRAILING SUBMATRIX. +* + CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, + $ A( J+1, J+1 ), LDA ) + END IF + 10 CONTINUE + RETURN +* +* END OF DGETF2 +* + END +CUT HERE............ diff --git a/potenl_pes.f b/potenl_pes.f new file mode 100644 index 0000000..29ddb69 --- /dev/null +++ b/potenl_pes.f @@ -0,0 +1,814 @@ + SUBROUTINE POTENL(ICNTRL, MXLMB, MPOTL, LAM, R, P, ITYP) +C +C ----------------------------------------------------------------- +C * MOLSCAT GENERAL POTENL ROUTINE; DESCRIPTION OF FUNCTIONS: +C ----------------------------------------------------------------- +C VERSION 14 IMPLEMENTS THREE OPTIONS FOR DESCRIBING THE POT'L +C 1. POT'L EXPANDED IN ANGULAR FUNCTIONS - SYMMETRIES DESCRIBED +C BY MXLAM,LAMBDA INPUT, RADIAL COEFFS DESCRIBED BY INPUT +C POWERS AND EXPONENTIALS *OR* VSTAR MECHANISM. +C THIS IS THE ORIGINAL MOLSCAT OPTION. +C MXLAM.GT.0 MUST BE INPUT AND LVRTP MUST BE .FALSE. (DEFAULT) +C 2. POT'L EXPANDED IN ANGULAR FUNCTIONS - PROJECTED VIA VRTP +C MECHANISM. SYMMETRIES MAY BE DESCRIBED *EITHER* BY +C A.) SYMMETRY DESCRIPTIONS INPUT VIA LAMBDA ARRAY +C MXLAM.GT.0 AND LVRTP=.TRUE. *MUST* BE INPUT +C B.) SYMMETRY DESCRIPTIONS GENERATED FROM LMAX (MMAX) +C MXLAM.LE.0 (DEFAULT) AND LMAX.GE.0 MUST BE INPUT +C IF BOTH ARE SPECIFIED (MXLAM.GT.0.AND.LMAX.GE.0) LMAX IS +C IGNORED, I.E., CASE (2-A) TAKES PRECEDENCE +C ALLOWED ONLY FOR NON-IOS CASES (ITYPE.LT.100) +C 3. POT'L IS NOT EXPANDED IN ANGULAR FUNCTIONS (SUITABLE FOR +C IOS CALCULATIONS ONLY) AND IS OBTAINED VIA THE VRTP MECHANISM +C MXLAM.LE.0 MUST BE SPECIFIED (AND ITYPE.GT.100 IN &BASIS) +C +C ----------------------------------------------------------------- +C * NOTES ON HISTORY OF ROUTINE: +C ----------------------------------------------------------------- +C +C *INTRODUCES XPT(MXPT,MXDIM), XWT(MXPT,MXDIM), INX(MXDIM),* +C * NPTS(MXDIM); NPTS IS IN NAMELIST /BASIN/ * +C * TO ALLOW GENERAL, MULTI-DIMENSIONAL PROJECTIONS * +C ********************************************************** +C CORRECTIONS 19 OCT 95 AFFECTING PROJECTION OF ITYPE=3 (SG) +C PROJECTION FOR ITYPE=3 ADDED 20 JUL 94 +C CODE FOR ITYPE=4 ADDED BY SG 30 JUN 94 (FOLLOWING TRP CODE) +C ITYPE=9 INTERFACE ADDED BY JMH 15 AUG 94 +C PREVIOUS REVISION DATES 1 FEB 1994 (SG); 3 JAN 1994 (JMH). +C ----------------------------------------------------------------- +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE LVRTP,ITSAVE,NTERM,NPOWER,A,E,NPT,NPS,NPTS,XPT,XWT, + 1 IXFAC,NDIM +c fl + save Rbig,coeff,nbpt +C +C ----------------------------------------------------------------- +C * NOTES FOR PROGRAMS OTHER THAN MOLSCAT (STORAGE CONSIDERATIONS): +C ----------------------------------------------------------------- +C THE X() ARRAY CAN BE DEFINED INTERNALLY OR, IF THIS ROUTINE +C IS USED WITH THE MOLSCAT CODE, IT IS TAKEN FROM THE +C /MEMORY/...,X() STORAGE MECHANISM IN MOLSCAT. +C THIS DECK SHOULD BE MODIFIED ACCORDINGLY IN THE STATEMENTS BELOW +C AND THE STATEMENTS WHICH FOLLOW STATEMENT NUMBER 2000 +C ----------------------------------------------------------------- +C ----- NEXT TWO STATEMENTS ARE USED FOR INTERNAL X() STORAGE ----- +C ----- ALSO, "X" MUST BE ADDED TO THE "SAVE" STATEMENT ABOVE ----- +C PARAMETER (MXX=30000) +C DIMENSION X(MXX) +C ----- NEXT TWO STATEMENTS ARE FOR MOLSCAT /MEMORY/ MECHANISM----- + DIMENSION X(1) + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X +C +C ----------------------------------------------------------------- +C * SPECIFICATION STATEMENTS: +C ----------------------------------------------------------------- +C MXDIM IS MAX NUMBER OF DIMENSIONS FOR PROJECTION +C MXPT LIMITS POINTS PER DIMENSION FOR PROJECTION +C MXHERM LIMITS HERMITE POLYNOMIALS FOR VIBRATIONAL PROJECTION + PARAMETER (MXPT=96, MXDIM=3, MXHERM=20) +C DIMENSIONS FOR LAMBDA AND POWER/EXPONENTIAL TERMS + PARAMETER (MXL=360, IXMX=200, IEXMX=200, NPXMX=20) + INTEGER CFLAG + LOGICAL QOUT,LVRTP, XLAM,LCALC + CHARACTER*8 QNAME(10), QTYPE(10) +C CHARACTER*6 PNAMES +C DIMENSION PNAMES(25),LOCN(25),INDX(25) + DIMENSION P(MXLMB), LAM(MXLMB) + DIMENSION NTERM(MXL),NPOWER(IXMX),NPUNI(NPXMX),LAMBDA(MXL) + DIMENSION A(IXMX), E(IEXMX) + DIMENSION H(MXHERM) + DIMENSION XPT(MXPT,MXDIM),XWT(MXPT,MXDIM),INX(MXDIM),NPTS(MXDIM) + EQUIVALENCE (NPT,NPTS(1)), (NPS,NPTS(2)) +C + EQUIVALENCE (MXLAM,MXSYM),(LMAX,L1MAX) + COMMON/NPOT/NPTL + COMMON/ANGLES/COSANG(7),FACTOR,IHOMO,ICNSYM,IHOMO2,ICNSY2 +c COMMON/FL/Rbig(200),coeff(200,200) +c fl + dimension Rbig(500),coeff(500,500) +c fl + dimension coef(500),b0(500),c0(500),d0(500) +C +C ----------------------------------------------------------------- +C * NAMELIST SPECIFICATION (AND DESCRIPTION OF PARAMETERS): +C ----------------------------------------------------------------- + NAMELIST/POTL/ RM,EPSIL,MXLAM,MXSYM,LAMBDA,NPOTL,NTERM, + 1 A,NPOWER,E,CFLAG,LVRTP,NPT,NPS, + 2 IHOMO,ICNSYM,LMAX,L1MAX,L2MAX,MMAX,IVMIN,IVMAX, + 3 NPTS,IHOMO2,ICNSY2 +C DATA PNAMES/'RM','EPSIL','MXLAM','MXSYM','LAMBDA','NPOTL','NTERM', +C 1 'A','NPOWER','E','CFLAG','LVRTP','NPT','NPS', +C 2 'IHOMO','ICNSYM','LMAX','L1MAX','L2MAX','MMAX','IVMIN','IVMAX', +C 3 'NPTS','IHOMO2','ICNSY2'/ +C DATA INDX/25*0/ +C +C RM - LENGTH SCALING FACTOR; VALUE IN ANGSTROMS +C EPSIL - ENERGY SCALING FACTOR; VALUE IN WAVENUMBERS (1/CM) +C MXLAM - NUMBER OF POTENTIAL TERMS RETURNED +C MXSYM - A SYNONYM FOR MXLAM, RETAINED FOR COMPATIBILITY +C LAMBDA - SYMMETRY INDICES FOR POTENTIAL +C NPOTL - NO LONGER A RELEVANT INPUT PARAMETER +C -------- BELOW DESCRIBE TERMS AS EXPONENETIALS/INVERSE POWERS +C NTERM - ARRAY: NTERM(I) IS NUMBER OF TERMS CONTRIBUTING TO P(I) +C NTERM(I) .LT. 0 CALLS VINIT/VSTAR FOR POTENTIAL TERM I +C A - ARRAY OF PRE-EXPONENTIAL (OR PRE-POWER) FACTORS +C FIRST NTERM(1) ELEMENTS REFER TO P(1), +C NEXT NTERM(2) ELEMENTS REFER TO P(2) ETC. +C NPOWER - ARRAY OF POWERS FOR POTENTIAL TERMS +C NPOWER HAS SAME ORDERING AS A +C NPOWER(J) .EQ. 0 INDICATES EXPONENTIAL +C E - ARRAY OF EXPONENTS: EACH ELEMENT OF THIS ARRAY +C CORRESPONDS TO A ZERO IN THE NPOWER ARRAY, +C IE E(1) CORRESPONDS TO FIRST ZERO, E(2) TO SECOND ETC. +C CFLAG - FLAG FOR SCALING POTENTIAL FOR ITYPE = 5 OR 6: +C SET CFLAG=1 IF INPUT A COEFFICIENTS ARE FOR AN +C EXPANSION IN C_LM INSTEAD OF Y_LM +C -------- BELOW ARE FOR POTENTIALS PROJECTION VIA VRTP MECHANISM +C LVRTP - LOGICAL FLAG FOR NON-EXPANDED POTENTIAL: +C MXLAM.LE.0 (DEFAULT) FORCES LVRTP=.TRUE. +C NPTS - NUMBERS OF GAUSS POINTS FOR PROJECTING POTENTIAL +C NPT - EQUIVALENT TO NPTS(1) +C NPS - EQUIVALENT TO NPTS(2) +C IHOMO - 2 IF POTENTIAL IS SYMMETRIC ABOUT THETA=90, 1 OTHERWISE +C ICNSYM - ORDER OF ROTATIONAL SYMMETRY ABOUT PRINCIPAL AXIS +C ALSO USED FOR 2ND MOLECULE (I.E., IHOMO2) IN ITYPE=3 +C (NOTE: IHOMO & ICNSYM ARE NORMALLY COMPUTED +C AUTOMATICALLY OR SET BY THE SUPPLIED VRTP ROUTINE) +C -------- BELOW ARE FOR AUTOMATIC GENERATION OF LAMBDA ARRAY; +C ONLY FOR PROJECTED POT'LS (LVRTP = TRUE) IF LMAX.GE.0 +C LMAX - INCLUDE ALL TERMS FROM 0 TO LMAX IN STEPS OF IHOMO +C L1MAX - MAX L1 VALUE FOR MOLECULE-1 (ITYPE=3) +C L2MAX - MAX L2 VALUE FOR MOLECULE-2 (ITYPE=3) +C MMAX - FOR ITYPE = 5 OR 6, EXCLUDE TERMS WITH M.GT.MMAX +C IVMIN, IVMAX - FOR ITYPE = 2, V LOOPS FROM IVMIN TO IVMAX +C + DATA QTYPE/'LAMBDA =','ABS(MU)=',' MU = ',' L1 = ', + 1 ' L2 = ',' L = ',' V = ','V-PRIME=', + 2 ' J = ','J-PRIME='/ +C +C STATEMENT FUNCTION ... + F(I)=DBLE(I+I+1) +C + +c define R grid for dvpt of radial coeff + + do iabc=1,56 + Rbig(iabc)=4.6d0+dble(iabc-1)*0.1d0 + enddo + do iabc=57,118 + Rbig(iabc)=10.2d0+dble(iabc-57)*0.25d0 + enddo + do iabc=119,195 + Rbig(iabc)=25.7d0+dble(iabc-119)*1d0 + nbpt=iabc + enddo + + IF (ICNTRL.GE.0) GOTO 1000 + IF (ICNTRL.EQ.-1) GOTO 2000 + WRITE(6,633) ICNTRL,R + STOP + + 1000 continue + +c write(*,*) 'bonjour12' + do i=1,MXLMB + do ii=1,nbpt + coef(ii)=coeff(ii,i) +c write(*,*) coef(ii) + enddo + call spline(nbpt, Rbig, coef, b0, c0, d0) + P(i)=seval(nbpt, R, Rbig, coef, b0, c0, d0) + enddo +c write(*,*) R,MXLMB,P(1),P(2),P(3) + + RETURN +C +C +C ****************************************************************** +C ** ** +C ** CODE BELOW IS FOR AN INITIALIZATION CALL ** +C ** ** +C ****************************************************************** +C + 2000 PI=ACOS(-1.D0) +C +C ------ NEXT TWO STATEMENTS ARE NEEDED IF USING AN INTERNAL ----- +C ------ X() ARRAY; I.E. NOT USING MOLSCAT /MEMORY/ MECHANISM +C MX=MXX +C IXNEXT=1 +C ------------------------------------------------------------------ +C + WRITE(6,634) +C INITIALIZE NAMELIST VARIABLES BEFORE READ + RM=1.D0 + EPSIL=1.D0 + MXLAM=0 + LMAX=-1 + L2MAX=-1 + MMAX=-1 + IVMIN=-1 + IVMAX=-1 + IHOMO=2 + ICNSYM=1 + ICNSY2=1 + IHOMO2=1 + CFLAG=0 + DO 2999 ID=1,MXDIM + 2999 NPTS(ID)=0 + LVRTP=.FALSE. + NPOTL=-1 +C +C NAMELIST/POTL/ RM,EPSIL,MXLAM,MXSYM,LAMBDA,NPOTL,NTERM, +C 1 A,NPOWER,E,CFLAG,LVRTP,NPT,NPS, +C 2 IHOMO,ICNSYM,LMAX,L1MAX,L2MAX,MMAX,IVMIN,IVMAX, +C 3 NPTS,IHOMO2,ICNSY2 +C------------------------------------------------------------------- +C ARRAYS FOR NAMELIST SIMULATOR +C LOCN(1)=LOC(RM) +C LOCN(2)=LOC(EPSIL) +C LOCN(3)=LOC(MXLAM) +C LOCN(4)=LOC(MXSYM) +C LOCN(5)=LOC(LAMBDA) +C LOCN(6)=LOC(NPOTL) +C LOCN(7)=LOC(NTERM) +C LOCN(8)=LOC(A) +C LOCN(9)=LOC(NPOWER) +C LOCN(10)=LOC(E) +C LOCN(11)=LOC(CFLAG) +C INDX(11)=4 +C LOCN(12)=LOC(LVRTP) +C INDX(12)=3 +C LOCN(13)=LOC(NPT) +C LOCN(14)=LOC(NPS) +C LOCN(15)=LOC(IHOMO) +C LOCN(16)=LOC(ICNSYM) +C LOCN(17)=LOC(LMAX) +C LOCN(18)=LOC(L1MAX) +C LOCN(19)=LOC(L2MAX) +C LOCN(20)=LOC(MMAX) +C LOCN(21)=LOC(IVMIN) +C LOCN(22)=LOC(IVMAX) +C LOCN(23)=LOC(NPTS) +C LOCN(24)=LOC(IHOMO2) +C LOCN(25)=LOC(ICNSY2) +C CALL NAMLIS('&POTL ',PNAMES,LOCN,INDX,25,IEOF) +C------------------------------------------------------------------- + READ(5,POTL) +C + IF (NPOTL.NE.-1) WRITE(6,602) NPOTL + ITYPE=ITYP-10*(ITYP/10) + LCALC=.FALSE. +C + XLAM=.FALSE. +C +C CHECK FOR LVRTP OR MXLAM.LE.0, ("UNEXPANDED" POTENTIAL CASE). +C + IF(MXLAM.LE.0) LVRTP=.TRUE. +C + WRITE(6,636) + IF (ITYP.GT.100 .OR. + 1 ITYPE.EQ.1 .OR. ITYPE.EQ.2 .OR. ITYPE.EQ.3. OR. + 2 ITYPE.EQ.5 .OR. ITYPE.EQ.6) + 2 GO TO 3010 + WRITE(6,637) ITYP + STOP +C + 3010 FACTOR=1.D0 + ITSAVE=ITYP +C CHECK/PROCESS IHOMO/ICNSYM INPUT + IF (IHOMO.NE.1.OR.ICNSYM.NE.1.OR.IHOMO2.NE.1.OR.ICNSY2.NE.1) THEN + WRITE(6,681) IHOMO,ICNSYM,IHOMO2,ICNSY2 +C FOR COMPATIBILITY WITH OLD CODE WHICH USES ICNSYM FOR IHOMO2 ... + IF (ITYPE.EQ.3.AND.IHOMO2.NE.1.AND.ICNSYM.EQ.1) ICNSYM=IHOMO2 + ENDIF +C INITIALIZATION CALL TO VRTP. +C IT MAY USE OR SET RM, EPSIL, IHOMO, ICNSYM + CALL VRTP(ICNTRL,RM,EPSIL) +C +C CHECK FOR VALID IHOMO, ICNSYM AFTER CALL TO VRTP + IF (IHOMO.NE.1) THEN + IF (IHOMO.NE.2) THEN + WRITE(6,606) IHOMO + STOP + ELSE + WRITE(6,*) ' &POTL INPUT OR VRTP SPECIFIES', + 1 ' HOMONUCLEAR SYMMETRY.' + ENDIF + ENDIF + IF (ICNSYM.LE.0) THEN + WRITE(6,*) ' *** POTENL. ILLEGAL &POTL ICNSYM =',ICNSYM + STOP + ELSEIF (ICNSYM.GT.1) THEN + WRITE(6,*) ' ICNSYM INPUT OR FROM VRTP SPECIFIES', + 1 ' AXIAL SYMMETRY, ICNSYM =',ICNSYM + ENDIF +C + +C +C ****************************************************************** +C CODE BELOW IS CASE 2 -- PROJECTED EXPANSION USING VRTP +C SYMMETRIES INPUT VIA *EITHER* LMAX *OR* MXLAM,LAMBDA +C LATTER TAKES PRECEDENCE IF BOTH ARE SPECIFIED. +C ****************************************************************** +C NPOTL FOR THIS CASE CALCULATED IN CODE BEGINNING AT 3999 +C + IF (LMAX.LT.0.AND.MXLAM.LE.0) THEN + WRITE(6,*) ' *** POTENL. LMAX.LT.0.AND.MXLAM.LE.0' + WRITE(6,*) ' YOU MUST SPECIFY SYMMETRIES VIA ONE', + 1 ' OR THE OTHER IN &POTL' + STOP + ELSEIF (LMAX.GE.0.AND.MXLAM.GT.0) THEN + WRITE(6,607) LMAX + LMAX=-1 + ENDIF +C +C FOR THE COUPLING CASES ALLOWED HERE (1,2,3,5,6) PROJECTING OUT +C THE POTENTIAL COEFFICIENTS INVOLVES A QUADRATURE OVER THETA. +C GET GAUSS-LEGENDRE QUADRATURE POINTS AND WEIGHTS, +C AND CHECK THAT NUMBER OF POINTS IS SENSIBLE. +C + WRITE(6,635) NPT + IF(LMAX.GE.0) THEN + MXLM=LMAX+1 + ELSE + IF(ITYPE.EQ.3) THEN + IADD=3 + ELSE + WRITE(6,638) ITYPE + STOP + ENDIF + MXLM=0 + IND=1 + DO 3011 I=1,MXLAM + MXLM=MAX(MXLM,LAMBDA(IND)) + 3011 IND=IND+IADD + MXLM=MXLM+1 + ENDIF +C + IF(MXLM.GT.NPT) WRITE(6,648) NPT,MXLM + NPT=MAX(NPT,MXLM) +C NB ABOVE CODE GUARANTEES THAT NPT.GE.1 + IF(NPT.GT.MXPT) GO TO 9400 +C + NEXP=NPT + CALL GAUSSP(-1.D0,1.D0,NPT,XPT(1,1),XWT(1,1)) + IF(NPT.NE.NEXP) THEN +C NB THIS BRANCH SHOULD NOT OCCUR WITH CURRENT GAUSSP + WRITE(6,653) NEXP + STOP + ENDIF +C + IF(IHOMO.EQ.2) THEN + DO 3014 IPT=1,NPT/2 + 3014 XWT(IPT,1)=2.D0*XWT(IPT,1) + NPT=(NPT+1)/2 + WRITE(6,*) ' HOMONUCLEAR SYMMETRY: ONLY HALF OF', + 1 ' THE THETA-1 POINTS WILL BE USED' + ENDIF +C +C SET UP OTHER QUADRATURE POINTS AND WEIGHTS FOR PROJECTING +C POTENTIAL COMPONENTS FOR ITYPE=1,2,3,5,6 +C + IF (ITYPE.EQ.3) GO TO 3003 + WRITE(6,638) ITYPE + STOP +C +C ITYPE = 3 LINEAR ROTOR - LINEAR ROTOR +C + 3003 IF (L1MAX.GE.0) THEN + LCALC=.TRUE. + IF (L2MAX.LT.0) L2MAX=L1MAX + MXLAM=0 + DO 3034 L1=0,L1MAX,IHOMO + DO 3034 L2=0,L2MAX,ICNSYM + LMIN=ABS(L1-L2) +C 19 OCT 95: LMAX->LTOP BELOW + LTOP=L1+L2 + DO 3034 LL=LMIN,LTOP,2 + MXLAM=MXLAM+1 + IF (3*MXLAM.GT.MXLMB) GO TO 9500 + LAM(3*MXLAM-2)=L1 + LAM(3*MXLAM-1)=L2 + 3034 LAM(3*MXLAM)=LL + ELSE + IF (3*MXLAM.GT.MXLMB) GO TO 9500 + L1MAX=0 + L2MAX=0 + DO 3134 I=1,MXLAM + LAM(3*I-2)=LAMBDA(3*I-2) + L1MAX=MAX(L1MAX,LAMBDA(3*I-2)) + LAM(3*I-1)=LAMBDA(3*I-1) + L2MAX=MAX(L2MAX,LAMBDA(3*I-1)) + 3134 LAM(3*I)=LAMBDA(3*I) + ENDIF + XLAM=.TRUE. + MAXV=MIN(L1MAX,L2MAX) + IF (NPS.LE.L2MAX) WRITE(6,648) NPS,L2MAX + NPS=MAX(NPS,L2MAX) + NEXP=NPS + WRITE(6,685) NPS + CALL GAUSSP(-1.D0,1.D0,NPS,XPT(1,2),XWT(1,2)) + IF(NPS.NE.NEXP) THEN +C NB THIS BRANCH SHOULD NOT OCCUR WITH CURRENT GAUSSP + WRITE(6,653) NEXP + STOP + ENDIF +C IF SYMMETRIC 2ND MOLECULE, REDUCE POINTS/INCREASE WEIGHTS + IF(ICNSYM.EQ.2) THEN + DO 3314 IPT=1,NPS/2 + 3314 XWT(IPT,2)=2.D0*XWT(IPT,2) + NPS=(NPS+1)/2 + WRITE(6,*) ' HOMONUCLEAR MOLECULE 2:', + 1 ' ONLY HALF THE POINTS WILL BE USED' + ENDIF +C SET UP GAUSS-MEHLER INTEGRATION FOR PHI ON (0,PI) + WRITE(6,675) NPTS(3) + IF (NPTS(3).LT.MAXV) THEN + WRITE(6,*) ' *** POTENL. INSUFFICIENT NUMBER OF POINTS', + 1 ' REQUESTED FOR PHI',NPTS(3) + WRITE(6,*) ' INCREASED TO',MAXV + NPTS(3)=MAXV + ENDIF + IF (NPTS(3).GT.MXPT) GO TO 9400 + FACTL=PI/DBLE(NPTS(3)) + TH=-FACTL/2.D0 + DO 3342 IX=1,NPTS(3) + TH=TH+FACTL + XWT(IX,3)=(2.D0*FACTL) + 3342 XPT(IX,3)=TH + NDIM=3 + IF (NDIM.GT.MXDIM) GO TO 9300 + NTOT=NPTS(1)*NPTS(2)*NPTS(3) + IXFAC=MX-MXLAM*NTOT + MX=IXFAC + IF (MX+1.LT.IXNEXT) GO TO 9600 +C + IX=IXFAC +C N.B. USE OF YRR MIGHT BE EXPENSIVE; CODE COULD BE MODIFIED +C SIMILARLY TO THAT IN IOSB1 + PI8=8.D0*PI*PI + DO 3329 IP3=1,NPTS(3) + DO 3329 IPX=1,NPTS(2) + DO 3329 IPT=1,NPTS(1) + DO 3329 IL=1,MXLAM + L1=LAM(3*IL-2) + L2=LAM(3*IL-1) + LL=LAM(3*IL) + IX=IX+1 + 3329 X(IX)=YRR(L1,L2,LL,XPT(IPT,1),XPT(IPX,2),XPT(IP3,3))*PI8/F(LL) + GOTO 3999 +C +C ATTEMPT TO PROCESS ITYPE AND POTENTIAL DESCRIPTION NUMBERS + 3999 QOUT=.TRUE. + NPOTL=MXLAM + NQPL=1 + WRITE(6,639) + ITYPE=ITYP-10*(ITYP/10) + IF(ITYPE.EQ.3) GOTO 2003 +C + WRITE(6,640) ITYPE + QOUT=.FALSE. + GOTO 2100 + + 2003 NQPL=3 + QNAME(1)=QTYPE(4) + QNAME(2)=QTYPE(5) + QNAME(3)=QTYPE(6) + WRITE(6,644) + IF(LCALC) THEN + WRITE(6,*) ' FOR MOLECULE - 1' + WRITE(6,615) L1MAX,IHOMO + WRITE(6,*) ' FOR MOLECULE - 2' + WRITE(6,615) L2MAX,ICNSYM + ENDIF + GOTO 2100 +C +C ******************************************************************* +C CODE BELOW IS MAINLY FOR CASE 1 - EXPANDED POTENTIAL +C USING NTERM,NPOWER,A,E *OR* VSTAR MECHANISM +C ******************************************************************* +C HOWEVER, CASE 2 - EXPANDED POT'L PROJECTED FROM VRTP +C ALSO RUNS THROUGH THIS CODE, BUT DOES LITTLE +C ******************************************************************* +C + 2100 IF (.NOT.XLAM.AND.NQPL*MXLAM.GT.MXL) WRITE(6,650) MXLAM,NQPL,MXL + IX=0 + IEX=0 + IQ=0 + NPX=0 + DO 9000 I=1,MXLAM +C OUTPUT SYMMETRY DESCRIPTION ONLY IF MXLAM,LAMBDA WERE USED +C I.E., LCALC=.FALSE. + IF(.NOT.LCALC) THEN + WRITE(6,651) I + IF(QOUT) WRITE(6,652) (QNAME(J),LAMBDA(IQ+J),J=1,NQPL) + WRITE(6,654) + ENDIF + IQ=IQ+NQPL + NT=NTERM(I) +C FOR CASE 2, LVRTP=.TRUE. AND WE SKIP PROCESSING + IF(LVRTP .OR. NT.EQ.0) GOTO 9000 + 9000 CONTINUE + WRITE(6,663) NPX +C IF(NPX.EQ.0) GOTO 9020 -- NOT REQUIRED IN FORTRAN 77 + DO 9010 I=1,NPX + 9010 WRITE(6,664) I, NPUNI(I) + 9020 CONTINUE +C +C IF LAM HAS NOT YET BEEN FILLED, GET FROM LAMBDA + IF (XLAM) GO TO 9050 + IF (MXLAM*NQPL.GT.MXLMB) GO TO 9500 + DO 9030 I=1,MXLAM*NQPL + 9030 LAM(I)=LAMBDA(I) + XLAM=.TRUE. +C +C COMMON RETURN POINT FOR ALL INITIALIZATIONS. +C SET VALUES BACK IN CALLING PARAMETERS. +C + 9050 WRITE(6,665) EPSIL,RM,MXLAM,NPOTL +C + R=RM + P(1)=EPSIL + MPOTL=NPOTL + MXLMB=MXLAM + +c fl save radial coefficient + do iabc=1,nbpt + + DO 1700 I=1,MXLMB + 1700 coeff(iabc,I)=0.D0 + NTOT=1 + DO 1710 ID=1,NDIM + INX(ID)=1 +c BELOW COULD BE ELIMINATED BY 'SAVE NTOT' + 1710 NTOT=NTOT*NPTS(ID) +c START YPT() INDEX = IX; +c IX COUNTS DOWN LAMBDA THEN 1ST DIMENSION, 2ND DIMENSION, ... + IX=IXFAC + DO 1800 I=1,NTOT + WEIGHT=1.D0 + DO 1810 ID=1,NDIM + COSANG(ID)=XPT(INX(ID),ID) + 1810 WEIGHT=WEIGHT*XWT(INX(ID),ID) + CALL VRTP(0,Rbig(iabc),SUM) + SUM=SUM*WEIGHT +c ACCUMULATE CONTRIBUTIONS TO EACH P() + DO 1820 IL=1,MXLMB + IX=IX+1 + 1820 coeff(iabc,IL)=coeff(iabc,IL)+SUM*X(IX) +c INCREMENT THE INDICES FOR EACH DIMENSION, INX(ID), STARTING W/ 1ST + ID=1 + 1830 INX(ID)=INX(ID)+1 + IF (INX(ID).LE.NPTS(ID)) GO TO 1800 +c WE REACH HERE IF WE'VE HIT MAX FOR THIS DIMENSION; START NEXT, + INX(ID)=1 + ID=ID+1 + IF (ID.LE.NDIM) GO TO 1830 +c IF WE REACH HERE WE SHOULD HAVE COUNTED ALL NTOT ELEMENTS + IF (I.EQ.NTOT) GO TO 1800 + WRITE(6,*) ' POTENL. ERROR IN PROJECTION. NO. TERMS',I + STOP + 1800 CONTINUE + + enddo + + RETURN +C +C ********** ERROR CONDITIONS ********** +C + 9300 WRITE(6,9301) NDIM,MXDIM + 9306 FORMAT(/' *** POTENL. PROJECTED POTENTIAL HAS',I3, + 1 ' DIMENSIONS, BUT MXDIM=',I3) + STOP + 9400 WRITE(6,9401) NPT,NPS,MXPT + 9401 FORMAT(/' *** POTENL. EITHER NPT OR NPS EXCEEDS MXPT' + 2 /' NPT =',I6,' NPS =',I6/' MXPT=',I7) +C WRITE(6,649) NPT,MXPT + STOP + 9500 WRITE(6,9501) MXLMB,MXLAM + 9501 FORMAT(/' *** POTENL. DIMENSION OF EXTERNAL LAM ARRAY EXCEEDED'/ + 1 ' SIZE PASSED FROM CALLING PROGRAM (MXLMB) =',I8/ + 2 ' OFFENDING VALUE OF MXLAM =',I8) + STOP +C +C BELOW IS REACHED IF THERE WAS NOT ENOUGH ROOM IN THE X ARRAY TO +C STORE THE PROJECTION COEFFS. IF USING /MEMORY/...X, IT IS +C POSSIBLE FOR THE CODE HERE TO OVERWRITE THE LAM ARRAY WITH +C COEFFS. HOWEVER, THE PROGRAM SHOULD THEN TERMINATE WHEN CHKSTR +C IS CALLED FROM DRIVER AFTER RETURN FROM POTENL INITIALIZATION. + 9600 NREQ=MXLAM*(NPT+NPS) + MXSTRT=MX+NREQ + WRITE(6,9601) NPT,NPS,MXLAM,NREQ,MXSTRT,MXSTRT-IXNEXT+1 + 9601 FORMAT(' *** POTENL. NOT ENOUGH ROOM FOR PROJECTION COEFFICIENTS'/ + 1 ' REQUIRES (',I4,' +',I4,') * ',I4,' =',I8/ + 2 ' OF',I8,' ORIGINALLY SUPPLIED IN X(), ONLY',I8, + 3 ' WERE AVAILABLE.') + STOP + +c format list + 9301 FORMAT(/' *** POTENL. DIMENSION NPXMX EXCEEDED',I6) + 633 FORMAT(/' *** ERROR IN POTENL, ICNTRL =',I6,' R =',E16.8) + 634 FORMAT(/' STANDARD MOLSCAT POTENL ROUTINE (AUG 94) ', + 1 'CALLED FOR POTENTIAL.'// + 2 ' /POTL/ DATA ARE --') + 602 FORMAT(/' *** POTENL. CURRENT CODE IGNORES INPUT &POTL NPOTL =', + 1 I6) + 636 FORMAT(/' POTENTIAL IS **NOT** EXPANDED IN ANGULAR FUNCTIONS.'// + 1 ' A SUITABLE VRTP ROUTINE MUST BE SUPPLIED.') + 637 FORMAT(' *** POTENL. ERROR VRTP NOT SUPPORTED FOR ITYPE =',I6) + 681 FORMAT(' INPUT VALUES ARE IHOMO =',I2,', ICNSYM =',I2, + 1 ', IHOMO2 =',I2,', ICNSY2 =',I2/ + 2 ' THESE MAY BE OVERRIDDEN BY VRTP') + 606 FORMAT(/' *** POTENL. ILLEGAL IHOMO =',I6,' FROM &POTL INPUT' + 1 ,' OR VRTP') + 607 FORMAT(' *** POTENL. IGNORING INPUT &POTL LMAX =',I4, + 1 ' IN FAVOR OF MXLAM, LAMBDA() VALUES') + 635 FORMAT(I4,'-POINT GAUSSIAN QUADRATURE REQUESTED TO PROJECT', + 1 ' COMMON THETA-1 COMPONENT') + 638 FORMAT(/' *** POTENL. ILLEGAL LOGICAL PATH. ITYPE =',I6) + 648 FORMAT(I4,'-POINT QUADRATURE IS INSUFFICIENT TO PROJECT OUT', + 1 ' LEGENDRE COMPONENTS REQUESTED'/' INCREASED TO ',I3, + 2 ' ACCORDINGLY') + 653 FORMAT(I4,'-POINT GAUSS-LEGENDRE QUADRATURE IS NOT AVAILABLE') + 685 FORMAT(I4,'-POINT GAUSSIAN QUADRATURE REQUESTED TO PROJECT', + 1 ' LEGENDRE COMPONENTS - MOLECULE 2') + 675 FORMAT(I4,'-POINT QUADRATURE REQUESTED TO PROJECT OUT', + 1 ' PHI COMPONENTS') + 639 FORMAT(/' ANGULAR DEPENDENCE OF POTENTIAL EXPANDED IN TERMS OF') + 640 FORMAT(/' *** POTENL. ITYPE =',I4,' CANNOT BE PROCESSED TO', + 1 ' DETERMINE THE POTENTIAL SYMMETRY LABLES') + 644 FORMAT(' CONTRACTED NORMALISED SPHERICAL HARMONICS, SUM', + 1 '(M1,M2,M) C(L1,M1,L2,M2,L,M) Y(L1,M1) Y(L2,M2) Y(L,M)'/ + 2 ' SEE RABITZ, J. CHEM. PHYS. 57, 1718 (1972)') + 615 FORMAT(' POTENTIAL SYMMETRIES GENERATED FROM LMAX =',I3, + 1 ' AND IHOMO =',I2) + 650 FORMAT(/' *** POTENL. MXLAM =',I4,' AND NQPL =',I2, + 1 ' APPEAR TO EXCEED INTERNAL STORAGE IN LAMBDA(',I5,')'/ + 2 ' WILL ATTEMPT TO PROCEED.') + 651 FORMAT(/' INTERACTION POTENTIAL FOR SYMMETRY TYPE NUMBER',I4) + 652 FORMAT(' WHICH HAS ',6(A8,I3,3X)) + 654 FORMAT(1X) + 663 FORMAT(/' NUMBER OF UNIQUE POWERS =',I4) + 664 FORMAT(' POWER',I3,' =',I4) + 665 FORMAT(/' POTENL PROCESSING FINISHED.'// + 1 ' ENERGY IN UNITS OF EPSILON =',F15.5,' CM-1'/ + 2 ' R IN UNITS OF RM =',F15.5,' ANGSTROMS'// + 3 ' MXLAM =',I5/' NPOTL =',I5) + + + END + +c routine for spline + + double precision function seval(n, u, x, y, b, c, d) + integer n + double precision u, x(n), y(n), b(n), c(n), d(n) +c +c this subroutine evaluates the cubic spline function +c +c seval = y(i) + b(i)*(u-x(i)) + c(i)*(u-x(i))**2 + d(i)*(u-x(i))**3 +c +c where x(i) .lt. u .lt. x(i+1), using horner's rule +c +c if u .lt. x(1) then i = 1 is used. +c if u .ge. x(n) then i = n is used. +c +c input.. +c +c n = the number of data points +c u = the abscissa at which the spline is to be evaluated +c x,y = the arrays of data abscissas and ordinates +c b,c,d = arrays of spline coefficients computed by spline +c +c if u is not in the same interval as the previous call, then a +c binary search is performed to determine the proper interval. +c + integer i, j, k + double precision dx + data i/1/ + if ( i .ge. n ) i = 1 + if ( u .lt. x(i) ) go to 10 + if ( u .le. x(i+1) ) go to 30 +c +c binary search +c + 10 i = 1 + j = n+1 + 20 k = (i+j)/2 + if ( u .lt. x(k) ) j = k + if ( u .ge. x(k) ) i = k + if ( j .gt. i+1 ) go to 20 +c +c evaluate spline +c + 30 dx = u - x(i) + seval = y(i) + dx*(b(i) + dx*(c(i) + dx*d(i))) + return + end + + subroutine spline (n, x, y, b, c, d) + integer n + double precision x(n), y(n), b(n), c(n), d(n) +c +c the coefficients b(i), c(i), and d(i), i=1,2,...,n are computed +c for a cubic interpolating spline +c +c s(x) = y(i) + b(i)*(x-x(i)) + c(i)*(x-x(i))**2 + d(i)*(x-x(i))**3 +c +c for x(i) .le. x .le. x(i+1) +c +c input.. +c +c n = the number of data points or knots (n.ge.2) +c x = the abscissas of the knots in strictly increasing order +c y = the ordinates of the knots +c +c output.. +c +c b, c, d = arrays of spline coefficients as defined above. +c +c using p to denote differentiation, +c +c y(i) = s(x(i)) +c b(i) = sp(x(i)) +c c(i) = spp(x(i))/2 +c d(i) = sppp(x(i))/6 (derivative from the right) +c +c the accompanying function subprogram seval can be used +c to evaluate the spline. +c +c + integer nm1, ib, i + double precision t +c + nm1 = n-1 + if ( n .lt. 2 ) return + if ( n .lt. 3 ) go to 50 +c +c set up tridiagonal system +c +c b = diagonal, d = offdiagonal, c = right hand side. +c + d(1) = x(2) - x(1) + c(2) = (y(2) - y(1))/d(1) + do 10 i = 2, nm1 + d(i) = x(i+1) - x(i) + b(i) = 2.*(d(i-1) + d(i)) + c(i+1) = (y(i+1) - y(i))/d(i) + c(i) = c(i+1) - c(i) + 10 continue +c +c end conditions. third derivatives at x(1) and x(n) +c obtained from divided differences +c + b(1) = -d(1) + b(n) = -d(n-1) + c(1) = 0. + c(n) = 0. + if ( n .eq. 3 ) go to 15 + c(1) = c(3)/(x(4)-x(2)) - c(2)/(x(3)-x(1)) + c(n) = c(n-1)/(x(n)-x(n-2)) - c(n-2)/(x(n-1)-x(n-3)) + c(1) = c(1)*d(1)**2/(x(4)-x(1)) + c(n) = -c(n)*d(n-1)**2/(x(n)-x(n-3)) +c +c forward elimination +c + 15 do 20 i = 2, n + t = d(i-1)/b(i-1) + b(i) = b(i) - t*d(i-1) + c(i) = c(i) - t*c(i-1) + 20 continue +c +c back substitution +c + c(n) = c(n)/b(n) + do 30 ib = 1, nm1 + i = n-ib + c(i) = (c(i) - d(i)*c(i+1))/b(i) + 30 continue +c +c c(i) is now the sigma(i) of the text +c +c compute polynomial coefficients +c + b(n) = (y(n) - y(nm1))/d(nm1) + d(nm1)*(c(nm1) + 2.*c(n)) + do 40 i = 1, nm1 + b(i) = (y(i+1) - y(i))/d(i) - d(i)*(c(i+1) + 2.*c(i)) + d(i) = (c(i+1) - c(i))/d(i) + c(i) = 3.*c(i) + 40 continue + c(n) = 3.*c(n) + d(n) = d(n-1) + return +c + 50 b(1) = (y(2)-y(1))/(x(2)-x(1)) + c(1) = 0. + d(1) = 0. + b(2) = b(1) + c(2) = 0. + d(2) = 0. + return + end + + diff --git a/v14_new.f b/v14_new.f new file mode 100644 index 0000000..b1ca846 --- /dev/null +++ b/v14_new.f @@ -0,0 +1,19256 @@ +C THIS ROUTINE IS THE MAIN PROGRAM FOR MOLSCAT VERSION 14 +C WITH DYNAMIC SPACE ALLOCATION CAPABILITY. +C +C INCREASE MXDIM AS NECESSARY TO PROVIDE SUFFICIENT WORKSPACE. +C IXNEXT,NIPR ARE INITIALIZED IN DRIVER +C IVLFL IS ALSO SET IN DRIVER; COULD BE CHANGED BY BASIN ROUTINES +C + PARAMETER (MXDIM=100000000) + DOUBLE PRECISION X + DIMENSION X(MXDIM) + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X +C + MX=MXDIM +C +C CALL PRINCIPAL MOLSCAT/BOUND SUBROUTINE +C + CALL DRIVER + STOP + END + SUBROUTINE DRIVER +C*********************************************************************** +C +C ------ MOLSCAT - J.M. HUTSON AND S.GREEN - VERSION 14 - JUL 94 ----- +C +C MAIN DRIVER FOR QUANTUM MOLECULAR SCATTERING PROGRAM +C +C REVISION HISTORY SINCE VERSION 7 OF SHELDON GREEN'S QCPE PROGRAM +C (MAY 79): +C +C VARIOUS NEW PROPAGATORS HAVE BEEN ADDED SINCE EARLY VERSIONS. +C THE COMPLETE LIST IN VERSION 12 IS: +C +C INTFLG =-1 : WKB METHOD FOR SINGLE CHANNEL, SINGLE TURNING POINT +C INTFLG = 2 : DEVOGELAERE'S PROPAGATOR +C INTFLG = 3 : WALKER-LIGHT R-MATRIX PROPAGATOR +C INTFLG = 4 : HYBRID LOG-DERIVATIVE / VIVS (VIVAS) PROPAGATOR +C INTFLG = 5 : JOHNSON'S LOG-DERIVATIVE PROPAGATOR +C INTFLG = 6 : MANOLOPOULOS'S DIABATIC MODIFIED +C LOG-DERIVATIVE PROPAGATOR +C INTFLG = 7 : MANOLOPOULOS'S QUASIADIABATIC MODIFIED +C LOG-DERIVATIVE PROPAGATOR +C INTFLG = 8 : ALEXANDER-MANOLOPOLOUS MODIFIED LOG-DERIVATIVE +C AIRY PROPAGATOR (HIBRIDON) + +C VERSION 8: CHANGES MADE BY CHRIS ASHTON (1982) AND JEREMY HUTSON +C (1982-4) AT WATERLOO AND CAMBRIDGE UNIVERSITIES. +C +C (1) ENTIRE PROGRAM CONVERTED TO DOUBLE PRECISION +C +C (2) GORDON ALGORITHM (INTFLG=1) REMOVED. +C +C (3) LOOP OVER "PARITY CASES" IN DRIVER HAS BEEN MADE EXPLICIT +C FOR CLARITY. +C +C (4) EIGENPHASE SUM CALCULATION AND RESONANCE SEARCH OPTION +C INCORPORATED. NEW OUTPUT CHANNEL (KSAVE) WITH OPTIONAL +C UNFORMATTED OUTPUT ON CHANNEL ISAVEU. +C +C (5) COLLISION TYPE ITYPE=10*N+7 HAS BEEN ADDED, +C FOR AN ATOM HITTING A DIATOMIC VIB-ROTOR, WHERE THE +C POTENTIAL MATRIX IS CONSTRUCTED BY DOING PROPERLY THE +C AVERAGING OF POTENTIAL TERMS OVER (V,J) AND (V',J') DIATOM +C INTERNAL STATES. +C +C (6) COLLISION TYPE ITYPE=8 ADDED, FOR ELASTIC SCATTERING OF ATOMS +C FROM CORRUGATED SURFACES. USES SUBROUTINE SURBAS TO SET UP +C THE BASIS SET. THE LOOPS IN DRIVER OVER JTOT AND M ARE USED +C TO LOOP OVER ANGLES THETA AND PHI RESPECTIVELY. +C +C (7) THE STORAGE OF THE COUPLING ARRAY VL HAS BEEN REARRANGED. THE +C METHOD OF CONSTRUCTING POTENTIAL MATRICES FROM IT HAS BEEN +C CHANGED, AND IN PARTICULAR A NEW INDEXING ARRAY IV HAS BEEN +C INTRODUCED. +C +C*********************************************************************** +C +C VERSION 9 (APR 86): JMH AND SG CODES UNIFIED +C +C (9) IOS CODE RE-INCORPORATED FROM SG'S PROGRAM. +C IT IS ACCESSED BY SETTING ITYPE = 100 + 'ITYPE' +C +C (10) MANOLOPOULOS'S DIABATIC AND ADIABATIC MODIFIED LOG-DERIVATIVE +C PROPAGATORS ADDED (INTFLG=6 AND 7 RESPECTIVELY). +C +C*********************************************************************** +C +C SG VERSION 10 (AUG 91): +C +C (10) NEW PRBR/IOSPB FOR OFF-DIAGONAL LINESHAPE CROSS SECTIONS, +C WITH HAS IN-CORE SIMULATION OF DIRECT ACCESS FILES. +C OUTPUT CROSS-SECTIONS NOW MULTIPLIED BY JSTEP (FOR JTOT). +C +C (11) ALEXANDER/MANOLOPOULOS MODIFIED LOG-DERIVATIVE/AIRY PROPAGATOR +C ADDED AS INTFLG=8. INTERFACED BY TIM PHILLIPS (NASA/GISS) +C +C VERSION 11 (JUN 92): JMH AND SG CODES INTEGRATED AGAIN. +C +C (12) LOOP OVER ENERGY IN DRIVER MODIFIED TO SIMPLIFY PARALLELISATION +C +C (13) ISAVEU OUTPUT MODIFIED TO USE UNFORMATTED WRITES +C +C (14) USAGE OF LINEAR ALGEBRA AND BLAS ROUTINES UNIFIED +C +C AND THE FOLLOWING ENHANCEMENTS ADDED FROM JMH'S CODE: +C +C (15) BASE9 INTERFACE ADDED +C +C (16) POTENL ENHANCED TO EVALUATE RADIAL STRENGTH FUNCTIONS BY +C QUADRATURE FOR ITYPE=1, 2, 5 AND 6. +C +C (17) CODE ADDED TO CALCULATE ASYMMETRIC TOP ENERGIES AND WAVEFUNCTION +C FROM ROTATIONAL CONSTANTS. MECHANISM FOR SELECTING ASYMMETRIC +C TOP STATES TO BE INCLUDED GENERALISED +C +C (18) CODE FOR ATOM-SPHERICAL TOP SCATTERING ADDED +C +C*********************************************************************** +C +C VERSION 12 (MAY 93) +C +C (19) DYNAMIC STORAGE HANDLING COMPLETELY REORGANIZED. +C +C (20) VECTOR/MATRIX ROUTINES RATIONALIZED TO USE LAPACK AND BLAS. +C +C (21) IV() ARRAY USED ONLY FOR 'NON-TRIVIAL' CASES. +C +C (22) OPTION TO WRITE VL ARRAY TO DISC TO AVOID EXCESSIVE MEMORY USE. +C +C (23) SOME CODE FOR COUPLING VL MATRIX ELEMENTS MODIFIED TO AVOID +C UNNECESSARY RECALCULATION OF NJ COEFFICIENTS +C +C*********************************************************************** +C +C VERSTION 13 (SG EXPERIMENTAL VERSION) APR 94, BUT CONTAINED IN V14 +C +C (24) IV ARRAY INTRODUCED FOR ITYPE=2 CASES +C +C (25) EXPANDED POTENL CAPABILITIES +C +C (26) BIGGER DIMENSIONS: /CMBASE/ ...ELEVEL(1000),...,JLEVEL(4000),... +C ALSO ADD ISYM(10),ISYM2(10); REORGANIZED ORDERING +C +C (27) CHANGES TO CALLING SEQUENCE FOR OUTINT/OUTPCH; IEXCH NOW CORRECT +C ON ISAVEU TAPE; BASE/OUTPCH RECOGNIZE CS SIGMA WHICH ARE +C NOT COMPLETE. +C +C*********************************************************************** +C +C VERSION 14 (JUL 94) +C +C (28) ISAVEU TAPE FORMAT CHANGE: NOPEN WITH JTOT,INRG,...,M,NOPEN REC +C +C (29) FILE='FILENAME' REMOVED FROM OPEN STATEMENTS +C +C (30) FLAG FOR NCAC,DTOL,OTOL INCREASED TO JTOTU=999999 +C +C (31) RESTART ABILITIES (IRSTRT) FROM ISAVEU +C +C (32) ITYPE=4 CODE (ASYMMETRIC TOP - LINEAR ROTOR) ADDED +C +C (33) COMMON /CMBASE/ ALTERED TO ALLOW MORE SPACE FOR LEVELS AND +C INTRODUCE EXTRA INPUT VARIABLES FOR HANDLING FUTURE EXTENSIONS. +C THIS CHANGE REQUIRES SIMILAR CHANGES IN BASE9 ROUTINES. +C +C (34) HANDLING OF TOTAL ENERGIES CHANGED IN PRESSURE BROADENING WITH +C IFEGEN=2 OPTION: AVOID CALCULATING S MATRICES THAT ARE NOT USED. +C +C*********************************************************************** +C +C EXTERNAL UNITS FOR MASSES ARE ATOMIC MASS UNITS (CARBON MASS/12) +C EXTERNAL UNITS FOR ENERGIES ARE WAVENUMBERS +C EXTERNAL UNITS FOR LENGTH RM ARE ANGSTROMS +C ALL OTHER LENGTHS ARE IN UNITS OF RM +C +C INTFLG CONTROLS METHOD OF SOLVING EQUATIONS. NPOTL AND MXLAM +C FOR SUM OVER ANGULAR DEPENDENCE OF POTENTIAL, NQN IS NO. OF +C QUANTUM NUMBERS NECESSARY TO DESCRIBE COLLISION PARTNERS. +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C ***** PROGRAM DIMENSION LIMITATIONS ***** +C ENERGY,TEMP,LINE DIMENSIONS LIMITED BY VALUES ... + PARAMETER(MXNRG=100,MXLN=200,MXTEMP=5) +C + INTEGER EUNITS,PRNTLV,PRINT,SHRINK + CHARACTER*4 EUNITC +C +C ARRAY TO HOLD TIME AND DATE +C INTEGER CTIME(2),CDATE(4) + CHARACTER CTIME*9,CDATE*11 +C +C TYPES FOR COMMON/LDVVCM/ + LOGICAL IALFP,IV,IVP,IVPP,NUMDER,ISHIFT,IDIAG,IPERT,ISYM + LOGICAL LCALC,ALDONE + LOGICAL IREAD,IWRITE + LOGICAL LWARN +C +C DOUBLE PRECISION LABEL(10) + CHARACTER*80 LABEL + CHARACTER*80 LABL + CHARACTER*1 TITLE(80),TIT(120),TIT2(120),BL + CHARACTER*8 PDATE + CHARACTER*8 CWD(2) + EQUIVALENCE (LABL,TITLE(1)) +C +C FOLLOWING ARRAYS ALL HAVE DIMENSION MXNRG. MXNRG IS THE MAXIMUM +C ALLOWED NUMBER OF TOTAL ENERGIES PER RUN. + DIMENSION ENERGY(MXNRG) + DIMENSION IECONV(MXNRG),ISST(MXNRG),MINJT(MXNRG),MAXJT(MXNRG) +C +C VARIABLES DIMENSIONED FOR NO. OF LINES IN PRES. BROAD. CALC. +C N.B. PRBRIN STILL MAX NO. LINES = 2*MXLN DESPITE OFF-DIAG CHANGES + DIMENSION LINE(2*MXLN),LTYPE(MXLN) + EQUIVALENCE (ILSU,IPRBRU), (NLPRBR,IFLS) +C + DIMENSION TEMP(MXTEMP) +C +C VARIABLES TO TEST PARTIAL WAVE CONVERGENCE + DIMENSION TEST(2) + EQUIVALENCE (TEST(1),DTOL),(TEST(2),OTOL) +C + DIMENSION NLABV(9) +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C MX,IXNEXT ARE MAX AND NEXT AVAILABLE LOCATION IN X() ARRAY +C IVLFL FLAGS WHETHER IV() ARRAY IS USED AS POINPER W/ VL ARRAY. +C NIPR IS NUMBER OF INTEGERS PER REAL; SHOULD BE 1 OR 2. +C E.G. FOR IBM R*8/I*4, NIPR=2. AN INTEGER ARRAY OF DIM. N +C CAN BE STORED IN A REAL ARRAY OF DIMENSION (N+NIPR-1)/NIPR. +C +C COMMON BLOCK FOR COMMUNICATING WITH COUPLED EQUATION SOLVERS + COMMON/DRIVE/STEST,STEPS,STABIL,CONV,RSTART,RSTOP,XEPS, + 1 DR,DRMAX,RMID,TOLHI,RTURN,VTOL,ESHIFT,ERED,RMLMDA, + 2 NOPEN,JKEEP,ISCRU,MAXSTP +C +C EXTRA COMMON BLOCK FOR LDVIVS + COMMON/LDVVCM/XSQMAX,ALPHA1,ALPHA2,IALPHA,IALFP,IV,IVP,IVPP, + 1 NUMDER,ISHIFT,IDIAG,IPERT,ISYM,IREAD,IWRITE +C +C COMMON BLOCK FOR WKB INTEGRATOR + COMMON/WKBCOM/NGMP(3) +C +C COMMON BLOCK TO SUBROUTINE OUTPUT FOR USE IN RESONANCE SEARCHES + COMMON/EIGSUM/EPSM(5) +C +C COMMON BLOCK FOR AIRPRP ARGUMENTS IN MANOLOPOLOUS/ALEXANDER +C PROPAGATOR + COMMON/HIBRIN/POWRX,DRAIRY,IABSDR +C + COMMON/VLSAVE/IVLU +C + NAMELIST /INPUT/ LABEL,RMIN,RMAX,IRMSET,IRXSET,URED,ISCRU,ISIGPR + 1 ,ITHROW,STEST,NNRG,ENERGY,DNRG,JTOTL,JTOTU,JSTEP,MSET,MHI,NCAC + 2 ,PRNTLV,INTFLG,MXSIG,STEPS,STABIL,NTEMP,NGAUSS,TEMP,EUNITS + 3 ,ISIGU,IPARTU,ILSU,IPRBRU,IFLS,NLPRBR,LINE,IFEGEN,LTYPE,MAXSTP + 4 ,TOLHI,RVIVAS,RVFAC,XSQMAX,ALPHA1,ALPHA2,IALPHA,EUNITC + 5 ,IALFP,IV,IVP,IVPP,NUMDER,ISHIFT,IDIAG,IPERT,ISYM + 6 ,ISAVEU,DTOL,OTOL,KSAVE,DR,DRNOW,DRMAX,RMID,VTOL,ICONV + 7 ,THETLW,THETST,PHILW,PHIST,MXPHI,SHRINK,LASTIN + 8 ,MMAX,LMAX,NGMP + 9 ,VMAX,TMAX,TOLLO,CTOL,UTEST,TOLER,TOL,MXXX,MNNN + A ,POWRX,DRAIRY,IABSDR,NNRGPG,IRSTRT +C + EQUIVALENCE (MXPAR,MXPHI), (RMID,RVIVAS), (DR,DRNOW), + 1 (TOL,TOLER,TOLHI) +C +C NGPT,LMAX, MMAX, AND NGMP(3) ARE VARIABLES ADDED FOR +C COMPATIBILITY WITH THE IOS PROGRAMS +C VARIABLES VMAX,...,MNNN ADDED FOR COMPATIBILITY WITH S.GREEN CODE +C (MOSTLY GORDON INTEGRATOR). ALSO TOL, TOLER, DRNOW +C +C RMIN IS THE RADIUS AT WHICH THE INTEGRATION IS BEGUN +C RMAX IS THE OUTER RADIUS TO WHICH THE INTEGRATION MUST EXTEND +C MAXSTP IS MAX NO. OF STEPS IN RADIAL INTEGRATION (INTFLG=3 ONLY) +C +C ARRAYS FOR NAMELIST SIMULATOR +C CHARACTER*6 INAMES +C DIMENSION INAMES(89),LOCN(89),INDX(89) +C +C DATA INAMES/'LABEL','RMIN','RMAX','IRMSET','IRXSET', +C 1 'URED','ISCRU','ISIGPR', +C 1 'ITHROW','STEST','NNRG','ENERGY','DNRG', +C 2 'JTOTL','JTOTU','JSTEP','MSET','MHI','NCAC', +C 2 'PRNTLV','INTFLG','MXSIG','STEPS','STABIL', +C 3 'NTEMP','NGAUSS','TEMP','EUNITS','ISIGU','IPARTU','ILSU', +C 4 'IPRBRU','IFLS','NLPRBR','LINE','IFEGEN','LTYPE','MAXSTP', +C 4 'TOLHI','RVIVAS','RVFAC','XSQMAX','ALPHA1','ALPHA2','IALPHA', +C 5 'IALFP','IV','IVP','IVPP','NUMDER','ISHIFT','IDIAG','IPERT', +C 6 'ISYM','ISAVEU','DTOL','OTOL','KSAVE','DR','DRNOW','DRMAX', +C 7 'RMID','VTOL','ICONV','THETLW','THETST','PHILW','PHIST', +C 8 'MXPHI','SHRINK','LASTIN','MMAX','LMAX','NGMP','VMAX', +C 9 'TMAX','TOLLO','CTOL','UTEST','TOLER','TOL','MXXX','MNNN' +C A 'PWRX','DRAIRY','IABSDR','NNRGPG','IRSTRT','EUNITC'/ +C DATA INDX/88*0/ +C +C DATA LABEL/10*' '/ + DATA CWD/' ','(8-BYTE)'/ + DATA CTIME/' '/,CDATE/' '/ + DATA IPROGM/14/, PDATE/'(MAR 95)'/ + DATA TITLE/80*' '/, BL/' '/ + DATA TIT/120*'='/, TIT2/120*'-'/ +C + DATA LTYPE/MXLN*-1/ + +C +C NLABV ARRAY CONTAINS NUMBER OF LABELS PER SYMMETRY TERM FOR EACH +C VALUE OF ITYPE (ITYPE=4 ADDED JUL 94 TRP/SG) + DATA NLABV/1,3,3,4,2,2,5,2,1/ +C +C THE PHYSICAL CONSTANTS USED ARE COMBINED IN THE SINGLE NUMBER BFCT. +C BFCT IS 0.5*(HBAR**2) IN UNITS OF (ATOMIC MASS UNITS)*(WAVENUMBERS) +C *(ANGSTROMS**2). +C THE FOLLOWING VALUE IS FROM THE 1973 PHYSICAL CONSTANTS. + DATA BFCT/16.857630D0/ +C +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +C +C CALL ROUTINE TO MASK FLOATING-POINT UNDERFLOW. + CALL MASK +C +C STORE VALUE OF MX IN CASE IT NEEDS TO BE RESET; +C NEEDED IN FUTURE CODE WHICH USES MAXMAX/MX TO ALLOCATE +C 'PERMANENT' STORAGE FOR A RUN W/ MULTIPLE (LASTIN=0) INPUT DECKS + MXSAVE=MX + + 100 MX=MXSAVE + CALL GCLOCK(TFIRST) + CALL GDATE(CDATE) + CALL GTIME(CTIME) + WRITE(6,110) IPROGM,PDATE,CDATE,CTIME,IPROGM,PDATE + 110 FORMAT(2X,8('----MOLSCAT----')/' |',120X,'|'/' |',24X, + 1 'COUPLED CHANNEL MOLECULAR SCATTERING PROGRAM OF J. M. HUTSON ', + 2 'AND S. GREEN',23X,'|'/' |',29X,'VERSION 1 BY S. GREEN ', + 3 '(NOV 1973); THIS IS VERSION',I3,1X,A8,29X,'|'/ + 4 ' |',120X,'|'/' |',44X,'RUN ON ',A11,2X, + 5 'AT ',A9,44X,'|'/' |',120X,'|'/2X,8('----MOLSCAT----')// + 6 2X,'PUBLICATIONS RESULTING FROM THE USE OF THIS PROGRAM SHOULD ', + 7 'REFER TO'/2X,'J. M. HUTSON AND S. GREEN, MOLSCAT COMPUTER ', + 8 'CODE, VERSION',I3,1X,A8 / + 9 2X,'DISTRIBUTED BY COLLABORATIVE COMPUTATIONAL PROJECT NO. 6 ', + A 'OF THE SCIENCE AND ENGINEERING RESEARCH COUNCIL (UK)') +C +C INITIALIZE STORAGE PARAMETERS IN /MEMORY/ + NIPR=2 + IXNEXT=1 +C SET IVLFL TO 1 TO ENSURE STORAGE COMPATIBILITY W/ VERSION 11 + IVLFL=1 +C SET NUSED.LT.0 AND CALL CHKSTR TO RESET COUNTER FOR EACH &INPUT. + NUSED=-1 + CALL CHKSTR(NUSED) +C +C SET INITIAL VALUES BEFORE READ(5,INPUT) . . . +C + LWARN=.FALSE. + IOSFLG=0 + NGMP(1)=8 + NGMP(2)=1 + NGMP(3)=16 + NNRG=0 + NNRGPG=1 + DNRG=0.D0 + NTEMP=0 + NGAUSS=3 + JSTEP=1 + JTOTL=-1 + JTOTU=-1 + MSET=0 + MHI=0 + MXSIG=0 + ISIGPR=0 + ITHROW=0 + DTOL=0.3D0 + OTOL=.005D0 + NCAC=4 + ISIGU = 0 + IPARTU=0 + ISAVEU=0 + KSAVE=0 + ILSU=11 + IFLS=0 + IFEGEN=0 + ICONV=0 + INTFLG=4 + RMIN=0.8D0 + RMAX=10.D0 + STEST=1.D-4 + STEPS=10.D0 + STABIL=5.D0 + ISCRU=0 + IRMSET=9 + IRXSET=1 + DR=2.D-2 + RMID=9999.D0 + RVFAC=0.D0 + DRMAX=5.D0 + VTOL=1.D-06 + MAXSTP=10000 + TOLHI=0.001D0 + XSQMAX=1.D04 + ALPHA1=1.D0 + ALPHA2=1.5D0 + IALPHA=6 + IALFP=.FALSE. + IV=.TRUE. + IVP=.FALSE. + IVPP=.FALSE. + NUMDER=.FALSE. + ISHIFT=.FALSE. + IDIAG=.FALSE. + IPERT=.TRUE. + ISYM=.TRUE. + EUNITS=0 + EUNITC=' ' + PRNTLV=0 + MXPHI=1 + THETLW=0.D0 + THETST=0.D0 + PHILW=0.D0 + PHIST=0.D0 + SHRINK=1 + LASTIN=1 + PI=ACOS(-1.D0) + POWRX=3.D0 + DRAIRY=-1.D0 + IABSDR=0 + IRSTRT=0 +C +C READ &INPUT DATA. +C OPEN(5,STATUS='OLD',SHARED,READONLY) +C---------------------------------------------------------------- +C ARRAYS FOR NAMELIST SIMULATOR +C LOCN(1)=LOC(LABEL) +C LOCN(2)=LOC(RMIN) +C LOCN(3)=LOC(RMAX) +C LOCN(4)=LOC(IRMSET) +C LOCN(5)=LOC(IRXSET) +C LOCN(6)=LOC(URED) +C LOCN(7)=LOC(ISCRU) +C LOCN(8)=LOC(ISIGPR) +C LOCN(9)=LOC(ITHROW) +C LOCN(10)=LOC(STEST) +C LOCN(11)=LOC(NNRG) +C LOCN(12)=LOC(ENERGY) +C LOCN(13)=LOC(DNRG) +C LOCN(14)=LOC(JTOTL) +C LOCN(15)=LOC(JTOTU) +C LOCN(16)=LOC(JSTEP) +C LOCN(17)=LOC(MSET) +C LOCN(18)=LOC(MHI) +C LOCN(19)=LOC(NCAC) +C LOCN(20)=LOC(PRNTLV) +C INDX(20)=4 +C LOCN(21)=LOC(INTFLG) +C LOCN(22)=LOC(MXSIG) +C LOCN(23)=LOC(STEPS) +C LOCN(24)=LOC(STABIL) +C LOCN(25)=LOC(NTEMP) +C LOCN(26)=LOC(NGAUSS) +C LOCN(27)=LOC(TEMP) +C LOCN(28)=LOC(EUNITS) +C INDX(28)=4 +C LOCN(29)=LOC(ISIGU) +C LOCN(30)=LOC(IPARTU) +C LOCN(31)=LOC(ILSU) +C LOCN(32)=LOC(IPRBRU) +C LOCN(33)=LOC(IFLS) +C LOCN(34)=LOC(NLPRBR) +C LOCN(35)=LOC(LINE) +C LOCN(36)=LOC(IFEGEN) +C LOCN(37)=LOC(LTYPE) +C LOCN(38)=LOC(MAXSTP) +C LOCN(39)=LOC(TOLHI) +C LOCN(40)=LOC(RVIVAS) +C LOCN(41)=LOC(RVFAC) +C LOCN(42)=LOC(XSQMAX) +C LOCN(43)=LOC(ALPHA1) +C LOCN(44)=LOC(ALPHA2) +C LOCN(45)=LOC(IALPHA) +C LOCN(46)=LOC(IALFP) +C LOCN(47)=LOC(IV) +C LOCN(48)=LOC(IVP) +C LOCN(49)=LOC(IVPP) +C LOCN(50)=LOC(NUMDER) +C LOCN(51)=LOC(ISHIFT) +C LOCN(52)=LOC(IDIAG) +C LOCN(53)=LOC(IPERT) +C LOCN(54)=LOC(ISYM) +C DO 115 I=46,54 +C 115 INDX(I)=3 +C LOCN(55)=LOC(ISAVEU) +C LOCN(56)=LOC(DTOL) +C LOCN(57)=LOC(OTOL) +C LOCN(58)=LOC(KSAVE) +C LOCN(59)=LOC(DR) +C LOCN(60)=LOC(DRNOW) +C LOCN(61)=LOC(DRMAX) +C LOCN(62)=LOC(RMID) +C LOCN(63)=LOC(VTOL) +C LOCN(64)=LOC(ICONV) +C LOCN(65)=LOC(THETLW) +C LOCN(66)=LOC(THETST) +C LOCN(67)=LOC(PHILW) +C LOCN(68)=LOC(PHIST) +C LOCN(69)=LOC(MXPHI) +C LOCN(70)=LOC(SHRINK) +C INDX(70)=4 +C LOCN(71)=LOC(LASTIN) +C LOCN(72)=LOC(MMAX) +C LOCN(73)=LOC(LMAX) +C LOCN(74)=LOC(NGMP) +C LOCN(75)=LOC(VMAX) +C LOCN(76)=LOC(TMAX) +C LOCN(77)=LOC(TOLLO) +C LOCN(78)=LOC(CTOL) +C LOCN(79)=LOC(UTEST) +C LOCN(80)=LOC(TOLER) +C LOCN(81)=LOC(TOL) +C LOCN(82)=LOC(MXXX) +C LOCN(83)=LOC(MNNN) +C LOCN(84)=LOC(POWRX) +C LOCN(85)=LOC(DRAIRY) +C LOCN(86)=LOC(IABSDR) +C LOCN(87)=LOC(NNRGPG) +C LOCN(88)=LOC(IRSTRT) +C LOCN(89)=LOC(EUNITC) +C +C CALL NAMLIS('&INPUT',INAMES,LOCN,INDX,89,IEOF) +C IF(IEOF.EQ.1) GOTO 1040 +C-------------------------------------------------------------- + READ(5,INPUT,END=1040) +C + WRITE(6,120) + 120 FORMAT(//' /INPUT/ DATA ARE --') + WRITE(LABL,'(A80)') LABEL + WRITE(6,130) LABL + 130 FORMAT(/' RUN LABEL = ',A80) + DO 140 IST=1,80 + IF(TITLE(IST).NE.BL) GOTO 150 + 140 CONTINUE + GOTO 190 + 150 DO 160 IND=1,80 + IF(TITLE(81-IND).NE.BL) GOTO 170 + 160 CONTINUE + GOTO 190 + 170 IND=81-IND + NST=(119-IND+IST)/2 + TIT(NST)=BL + TIT2(NST)=BL + DO 180 I=IST,IND + NST=NST+1 + TIT(NST)=TITLE(I) + TIT2(NST)=TITLE(I) + 180 CONTINUE + TIT(NST+1)=BL + TIT2(NST+1)=BL +C + 190 AMXKB=MX/128.D0 + IF (NIPR.EQ.1.OR.NIPR.EQ.2) THEN + WRITE(6,200) MX,CWD(NIPR),AMXKB + 200 FORMAT(/' SCRATCH CORE STORAGE ALLOCATION IS',I10,A8, + 1 ' WORDS (',F10.2,' KBYTES)') + WRITE(6,202) NIPR + 202 FORMAT(2X,I1,' INTEGER(S) CAN BE STORED IN EACH WORD.') + ELSE + WRITE(6,204) NIPR + 204 FORMAT(/' *** ILLEGAL NIPR =',I10) + ENDIF +C + PRINT=PRNTLV +C +C PROCESS INTFLG -- REQUESTED PROPAGATOR -- AND ITS INPUT DATA. +C + WRITE(6,210) INTFLG + 210 FORMAT(/' INTEGRATOR REQUESTED BY INPUT VALUE INTFLG =',I3) + 220 FORMAT(/' ***** ERROR - NO IMPLEMENTATION FOR THIS INTFLG' + 1 ,' - RUN HALTED.') + 240 FORMAT(/' COUPLED EQUATIONS SOLVED BY METHOD OF DEVOGELAERE.') + 250 FORMAT(/' INTEGRATION PARAMETERS ARE RMIN =',F7.2/ + 1 30X,'RMAX =',F7.2/30X,'STEST =',D11.2/30X,'STEPS =', + 2 F6.1,' (PER WAVELENGTH)'/30X,'STABIL =',F6.1,' (STEPS PER', + 3 ' STABILIZATION)') + 270 FORMAT(/' COUPLED EQUATIONS SOLVED BY WALKER-LIGHT R-MATRIX', + 1 ' PROPAGATOR ALGORITHM'//' PARAMETERS ARE',5X,'RMIN =', + 2 F7.2,8X,'DR = ',G8.2/21X,'RMAX =',F7.2,8X, + 3 'VTOL =',D9.2/21X,'RMID =',F7.2,8X,'MAXSTP =',I9) + 271 FORMAT(/' RVFAC =',F7.2,' OVERRIDES INPUT RMID') + 300 FORMAT(/' COUPLED EQUATIONS SOLVED BY LOG DERIVATIVE METHOD ', + 1 'OF JOHNSON') + 310 FORMAT(/' INTEGRATION PARAMETERS ARE RMIN =',F7.2,8X, + 1 'STEPS = ',F7.1/33X,'RMAX =',F7.2) + 320 FORMAT(/' CHANGING TO VARIABLE INTERVAL / VARIABLE STEP METHOD', + 1 ' AT LONG RANGE'//' INTEGRATION PARAMETERS ARE RVIVAS =', + 2 F7.2,8X,'DR =',G8.2/ + 3 33X,'RMAX =',F7.2,8X,'DRMAX =',F8.2/ + 4 56X,'ALPHA1 = ',F7.2/33X,'XSQMAX =',G7.1,8X,'ALPHA2 = ',F7.2/ + 5 33X,'TOLHI =',G7.1,8X,'IALPHA =',I8/33X,'ISHIFT =',L7,8X, + 6 'IV =',L8/33X,'IPERT =',L7,8X,'IVP =',L8/33X, + 7 'IALFP =',L7,8X,'IVPP =',L8/33X,'ISYM =',L7,8X, + 8 'NUMDER =',L8) + 340 FORMAT(/' COUPLED EQUATIONS SOLVED BY DIABATIC ', + 1 'MODIFIED LOG DERIVATIVE METHOD OF MANOLOPOULOS') + 350 FORMAT(/' COUPLED EQUATIONS SOLVED BY QUASIADIABATIC ', + 1 'MODIFIED LOG DERIVATIVE METHOD OF MANOLOPOULOS') + 352 FORMAT(33X,'IABSDR =',I4) + 353 FORMAT(33X,'OVERRIDES STEPS PARAMETER WITH DR =',F9.3) + 354 FORMAT(/' AIRY PARAMETERS ','RMID =',F10.4/ + 2 33X,'DRAIRY=',F10.4/33X,'TOLHI=',F13.6/ + 3 33X,'POWRX =',F8.2) + 355 FORMAT(/' DRAIRY.LT.0 TAKES INITIAL AIRY STEP SIZE FROM' + 1 ,' MODIFIED LOG-DERIVATIVE VALUE.') + 356 FORMAT(/' TOLHI.GE.1 -- AIRY STEP SIZE INCREASED BY' + 1 ,' FACTOR OF TOLHI AT EACH STEP') + 357 FORMAT(/' TOLHI.LT.1 -- AIRY STEPS ADJUSTED TO MAINTAIN' + 1 ,' APPROX. ACCURACY VIA PERTURBATION THEORY AND POWRX.') + 370 FORMAT(/' EQUATIONS SOLVED BY WKB APPROXIMATION WITH GAUSS-' + 1 ,'MEHLER INTEGRATION. SEE R. T PACK, JCP 60, 633 (1974).'/ + 2 /' NOTE THAT THIS IS IMPLEMENTED ONLY FOR ONE CHANNEL', + 3 ' CASES, E.G., IOS CALCULATIONS.'/ + 4 /' INTEGRATION PARAMETERS ARE RMIN =',D15.4/ + 5 30X,'STEST =',D14.4/30X,'NGMP =',I6,' (',I2,')',I3) +C + IF(INTFLG.EQ.2) THEN + WRITE(6,240) +C STABIL=MIN(STABIL,STEPS/2.D0) + WRITE(6,250) RMIN,RMAX,STEST,STEPS,STABIL + GO TO 380 + ENDIF +C + IF(INTFLG.EQ.3) THEN + WRITE(6,270) RMIN,DR,RMAX,VTOL,RMID,MAXSTP + IF(RVFAC.GT.0.D0 .AND. IRMSET.GT.0) WRITE(6,271) RVFAC + GO TO 380 + ENDIF +C + IF(INTFLG.EQ.4 .OR. INTFLG.EQ.5) THEN + IF(IDIAG) THEN + IV=.TRUE. + IVP=.TRUE. + IVPP=.TRUE. + ISHIFT=.TRUE. + IPERT=.TRUE. + ENDIF + IF(INTFLG.EQ.5) RVIVAS=RMAX + WRITE(6,300) + WRITE(6,310) RMIN,STEPS,RVIVAS + IF(INTFLG.EQ.4) WRITE(6,320) RVIVAS,DR,RMAX,DRMAX,ALPHA1,XSQMAX, + 1 ALPHA2,TOLHI,IALPHA,ISHIFT,IV,IPERT,IVP,IALFP,IVPP,ISYM,NUMDER + GO TO 380 + ENDIF +C + IF(INTFLG.EQ.6) THEN + WRITE(6,340) + WRITE(6,310) RMIN,STEPS,RMAX + GO TO 380 + ENDIF +C + IF(INTFLG.EQ.7) THEN + WRITE(6,350) + WRITE(6,310) RMIN,STEPS,RMAX + GO TO 380 + ENDIF +C + IF(INTFLG.EQ.8) THEN + CALL MHAACK(6) + WRITE(6,310) RMIN,STEPS,RMAX + WRITE(6,352) IABSDR + IF(IABSDR.EQ.1) WRITE(6,353) DR + WRITE(6,354) RMID,DRAIRY,TOLHI,POWRX + IF(RVFAC.GT.0.D0.AND.IRMSET.GT.0) WRITE(6,271) RVFAC + IF(DRAIRY.LT.0.D0) WRITE(6,355) + IF(TOLHI.GE.1.D0) THEN + WRITE(6,356) + ELSE + WRITE(6,357) + ENDIF + GO TO 380 + ENDIF +C + IF(INTFLG.EQ.-1) THEN + WRITE(6,370) RMIN,STEST,NGMP + GO TO 380 + ENDIF +C + WRITE(6,220) + STOP +C + 380 JKEEP=-1 + XEPS=-1.D0 + DEEP=1.D30 + IF(IRXSET.GT.0) WRITE(6,381) IRXSET + 381 FORMAT(/' IRXSET =',I3,' OPTION. RMAX ADJUSTED AUTOMATICALLY ', + 1 'FOR EACH NEW JTOT,MVAL') + IF(IRMSET.LE.0) GOTO 420 + WRITE(6,390) IRMSET + 390 FORMAT(/' IRMSET =',I3,' OPTION. RMIN CHOSEN AUTOMATICALLY ', + 1 'FOR EACH NEW JTOT') +C +C XEPS IS SUCH THAT AIRY(XEPS) APPROX. EQUALS 10**(-IRMSET) +C + XEPS=(-1.5D0*LOG(4.D0*SQRT(PI)* + 1 10.D0**(-IRMSET)))**(2.D0/3.D0) +C>>SG 1/18/93 BELOW REMOVED AT SUGGESTION OF JMH +C IF(ISCRU.EQ.0 .AND. NNRG.NE.1) SHRINK=0 + IF(INTFLG.NE.3 .OR. SHRINK.NE.1) GOTO 420 + DEEP=2.D0+XEPS**1.5D0/1.5D0 + WRITE(6,400) + 400 FORMAT(22X,'AND DEEPLY CLOSED CHANNELS ', + 1 'DROPPED IN LONG-RANGE REGION') + IF(NNRG.NE.1 .AND. ISCRU.NE.0) WRITE(6,410) + 410 FORMAT(22X,'NOTE THAT BASIS SET CONTRACTION IS PERFORMED FOR ', + 1 'ENERGY(1),'/22X,'SO THAT SUBSEQUENT ENERGIES MUST NOT BE ', + 2 'SIGNIFICANTLY HIGHER.') +C + 420 ISAV=0 + IF(JTOTL.EQ.JTOTU .AND. MSET.GT.0) ISAV=1 + IF(ISCRU.LT.0) ISAV=-ISAV + ISCRU=IABS(ISCRU) +C + IF(ISCRU.EQ.0) THEN + IF(NNRG.GT.1.OR.NTEMP.GT.0) WRITE(6,430) + 430 FORMAT(/' ***** WARNING - NO SCRATCH FILE SPECIFIED BY ISCRU ', + 1 'PARAMETER - FULL CALCULATION WILL BE DONE AT EACH ENERGY') + ELSE + IF(ISAV.EQ.-1) THEN + WRITE(6,440) ISCRU + 440 FORMAT(/' ENERGY-INDEPENDENT MATRICES SAVED FROM A ', + 1 'PREVIOUS RUN WILL BE READ FROM UNIT',I3) + OPEN(ISCRU,FORM='UNFORMATTED',STATUS='OLD') + ELSE + WRITE(6,450) ISCRU + 450 FORMAT(/' ENERGY-INDEPENDENT MATRICES WILL BE SAVED ', + 1 'TEMPORARILY ON UNIT',I3) + OPEN(ISCRU,FORM='UNFORMATTED',STATUS='UNKNOWN') + ENDIF + ENDIF +C + WRITE(6,470) URED + 470 FORMAT(/' REDUCED MASS FOR COLLISION =',F14.9,' A.M.U.') + IF(JTOTL.LT.0) JTOTL=0 + IF(JTOTU.LT.JTOTL) JTOTU=999999 + WRITE(6,480) JTOTL,JTOTU,JSTEP + 480 FORMAT(/' CONTROL DATA FOR TOTAL ANGULAR MOMENTUM IS'/ + 1 7X,'JTOT FROM',I4,' TO',I6,' IN STEPS OF',I4) + IF(JTOTU.GE.999999) WRITE(6,490) NCAC,DTOL,OTOL + 490 FORMAT(/' JTOT SERIES WILL BE TERMINATED WHEN MAX CHANGE IN ', + 1 'CROSS SECTIONS IS LESS THAN TOLERANCE FOR NCAC =',I3, + 2 ' CONSECUTIVE JTOT'/25X, + 3 'DIAGONAL (DTOL) AND OFF-DIAGONAL (OTOL) TOLERANCES ARE',2F9.5) + IF(JTOTU.GE.999999.AND.NNRGPG.GT.1) WRITE(6,491) NNRGPG + 491 FORMAT(/' N.B. CONVERGENCE CHECKING IS DONE FOR ENERGY GROUPS', + 1 ' OF NNRGPG =',I4) + IF(MSET.GT.0 .AND. MHI.LE.0) MHI=MSET + IF(MSET.GT.0) WRITE(6,500) MSET,MHI + 500 FORMAT(/' CALCULATIONS WILL BE FOR SYMMETRY BLOCK ("PARITY ', + 1 'CASES")',I4,' TO',I4) +C +C PROCESS TOTAL ENERGIES +C + CALL ECNV(EUNITS,EUNITC,EFACT) + IF(NNRG.GT.0 .AND. DNRG.EQ.0.D0 .AND. ABS(EFACT-1.D0).GT.1.D-3 + 1 .AND. ICONV.EQ.0) WRITE(6,510) (ENERGY(I),I=1,NNRG) + 510 FORMAT(/' INPUT ENERGY LIST IS'/(16X,7D16.6)) + IF(NTEMP.LE.0) GOTO 520 +C OVERRIDE ENERGY INPUT WITH TEMP INPUT + NTEMP=MIN0(NTEMP,MXTEMP) + CALL EAVG(NTEMP,TEMP,NGAUSS,ENERGY,NNRG,MXNRG) + NPR=NNRG + GOTO 590 + 520 ISRCH=0 + NPR=NNRG +C +C PROCESS A NEGATIVE INPUT NNRG FOR RESONANCE SEARCH OPTION +C + IF(NNRG.GE.0 .OR. DNRG.EQ.0.D0 .OR. JTOTL.NE.JTOTU .OR. + 1 MSET.LE.0 .OR. KSAVE.LE.0) GOTO 530 + ISRCH=1 + NNRG=5*(IABS(NNRG)/5) + MXN=5*(MXNRG/5) + NNRG=MIN0(NNRG,MXN) + NNRGPG=5 + NPR=5 +C + 530 NNRG=MIN0(MXNRG,NNRG) + NPR=MIN0(MXNRG,NPR) + IF(NNRG.GT.0) GOTO 550 + WRITE(6,540) + 540 FORMAT(/' ***** ERROR - NO INPUT ENERGIES SPECIFIED - RUN HALTED') + STOP + 550 IF(NNRG.LE.1 .OR. (DNRG.EQ.0.D0 .AND. ICONV.EQ.0)) GOTO 570 + DO 560 I=2,NPR + 560 ENERGY(I)=ENERGY(1)+(I-1)*DNRG + 570 DO 580 I=1,NPR + 580 ENERGY(I)=ENERGY(I)*EFACT + 590 WRITE(6,600) NNRG + 600 FORMAT(/' CONTROL DATA FOR TOTAL ENERGIES. CALCULATIONS WILL ', + 1 'BE PERFORMED FOR',I4,' VALUES') + DO 610 I=1,NPR + ENEV=ENERGY(I)/8065.5410D0 + 610 WRITE(6,620) I,ENERGY(I),ENEV + 620 FORMAT(7X,'ENERGY NO.',I4,' =',F17.9,' (1/CM) =',F17.12,' E.V.') +C + IF(ISRCH.EQ.1) WRITE(6,630) + 630 FORMAT(/' RESONANCE SEARCH OPTION. ONLY FIRST 5 ENERGIES ', + 1 'GIVEN. OTHERS WILL BE DETERMINED INTERACTIVELY.') +C + IF(IFLS.GT.0 .AND. IFEGEN.GT.0) WRITE(6,640) + 640 FORMAT(/' THESE ENERGY VALUES WILL BE USED AS RELATIVE (CENTER', + 1 ' OF MASS) VALUES AND LIST MAY BE MODIFIED ACCORDINGLY.') +C + IF(NUMDER) WRITE(6,641) + 641 FORMAT(/' NUMDER=.TRUE. POTENTIAL DERIVATIVE WILL BE COMPUTED', + & ' NUMERICALLY FROM POTENTIAL.') + WRITE(6,650) PRINT,ISIGPR,ITHROW + 650 FORMAT(/' PRINT LEVEL (PRNTLV) =',I3,' OTHER PRINT CONTROLS', + 1 ' ISIGPR =',I2,' ITHROW =',I2) + WRITE(6,660) + 660 FORMAT(/' ',30('====')) +C +C INITIALIZE BASIS (BASIN/IOSBIN) +C COMBINED MOLSCAT (BASIN) AND IOS (IOSBIN) -- APR 86 +C IOSBIN GRABS STORAGE IN ATAU=JLEV=X (ITYPE=6 ONLY). MAX AVAILABLE +C PASSED INITIALLY IN NLEV; SET6I/IOSBIN MUST UPDATE +C IC ACCORDINGLY. N.B. IOS CASE ALSO USES NLEV TO PASS 'NVC' +C FROM BASIN/IOSBIN TO IOSDRV. +C BASIN TAKES STORAGE FOR JLEV=X, AND ALSO RESETS IC ACCORDINGLY; +C FOR THIS CASE, NLEV INITIALIZED TO MAXIMUM AVAILABLE IN X(). + IXJLEV=IXNEXT + NLEV=MX +C IXNEXT REMOVED FROM ARGUMENT LIST: JMH, 10 NOV 93 + CALL BASIN(NLEV,X(IXJLEV),URED,NQN,NLABV(9),MXPAR,ITYPE,IOSFLG) +C BASE ROUTINE INCREMENTS IXNEXT BY AMOUNT OF STORAGE IN JLEV. + CALL CHKSTR(NUSED) + WRITE(6,660) +C +C INITIALIZE POTENTIAL. +C + ILAM=IXNEXT + MXLAM=NIPR*(MX-ILAM+1) + CALL POTENL(-1,MXLAM,NPOTL,X(ILAM),RM,EPSIL,ITYPE) + +C THIS READS (5, POTL). RM AND EPSIL ARE SET HERE. +C RM IS A LENGTH PARAMETER (IN ANGSTROMS) +C EPSIL IS AN ENERGY PARAMETER IN WAVENUMBERS. + ITYP=MOD(ITYPE,10) +C INCREMENT IXNEXT FOR STORAGE TAKEN FOR LAM(NLABV,MXLAM) + IXNEXT=IXNEXT+(MXLAM*NLABV(ITYP)+NIPR-1)/NIPR + CALL IVCHK(IVLFL,PRNTLV,ITYPE,NLABV,MXLAM,NPOTL,X(ILAM)) + WRITE(6,660) +C +C COMPUTE SOME DIMENSIONLESS PARAMETERS +C +C RMLMDA IS THE SQUARE OF THE RATIO OF RM TO DEBROGLIE WAVELENGTH + RMLMDA=URED*RM*RM*EPSIL/BFCT +C CINT IS THE FACTOR TO REDUCE THE ROTATIONAL CONSTANTS + CINT = RMLMDA/EPSIL +C +C *** + IF(IOSFLG.LE.0) GOTO 670 +C *** +C *** THIS IS WHERE IOS CODE DIVERGES - CALL IOS CODE AND SKIP TO EXIT +C *** + IF (IRSTRT.NE.0) THEN + WRITE(6,*) ' *** RESTART REQUESTED WITH IOS RUN - NOT ALLOWED' + WRITE(6,*) ' *** MODIFY INPUT DECK AND RESUBMIT' + STOP + ENDIF + CALL IOSDRV(NNRG,NPR,ENERGY,JTOTL,JTOTU,JSTEP,TEST,NCAC, + 1 IFLS,LINE,LTYPE,MXLN,INTFLG,ITYPE,LMAX,MMAX, + 2 IPROGM,URED,LABL,NUMDER, + 3 X(ILAM),MXLAM,NPOTL,CINT,IRMSET,IRXSET,RVFAC, + 4 DEEP,PRINT,NLEV,ISAVEU,TFIRST,RM,EPSIL,RMIN,RMAX) + CALL GCLOCK(TLAST) + TOTIME=TLAST-TFIRST + GOTO 1020 +C +C PROCESS PRESSURE-BROADENING LINE-SHAPE INPUT PARAMETERS. +C + 670 IF(IFLS.GT.0) THEN + CALL PRBRIN(IFLS,LINE,LTYPE,MXLN,ILSU,NNRG,ENERGY,MXNRG,IFEGEN, + 1 X(IXJLEV),PRINT) + IF(IFEGEN.GT.0) NPR=NNRG + WRITE(6,660) + IF(KSAVE.EQ.0) GOTO 690 + WRITE(6,680) IFLS,KSAVE + 680 FORMAT(/' ****** WARNING. IFLS =',I3,' AND KSAVE =',I3,' ARE ', + 1 'INCOMPATIBLE. KSAVE IS RESET TO ZERO') + KSAVE=0 + ENDIF +C +C INITIALIZE OUTPUT ROUTINE. +C OUTPUT TAKES AN ADDITIONAL AMOUNT OF STORAGE +C FOR SIG AT X(IXNEXT) AND INCREASES IXNEXT ACCORDINGLY. +C + 690 IOUT=IXNEXT +C NOTE THAT IXNEXT WILL BE CHANGED BY OUTINT + CALL OUTINT(LABL,ENERGY,NNRG,NLEV,NQN,X(IXJLEV),X(IOUT),IXNEXT, + 1 IECONV,URED,ITYPE,KSAVE,ISST,MINJT,MAXJT,ISIGU,IPARTU,ISAVEU, + 2 IPROGM,MXSIG,ISIGPR,JSTEP,IRSTRT) + CALL CHKSTR(NUSED) + IC1=IXNEXT +C PROCESS RESTART REQUEST ... + MXP=0 + CALL RESTRT(IRSTRT,ISAVEU,JTOTL,JSTEP,MXPAR,MSET,MHI, + 1 LABEL,ITYPE,NLEV,NQN,URED,IPROGM, + 2 X(IXJLEV),NNRG,ENERGY,MXNRG, + 3 X(IOUT),ISST,IECONV,MINJT,MAXJT,ISIGU,IPARTU,KSAVE, + 4 OTOL,DTOL,X(IC1),X(IC1),MRSTRT,IERST,MXP,PRINT) + WRITE(6,660) +C + EFIRST=ENERGY(1)*CINT + CALL GCLOCK(TITIME) + TTIME=TITIME-TFIRST + WRITE(6,700) TTIME,NUSED + 700 FORMAT(/' INITIALIZATION DONE. TIME WAS',F7.2,' CPU SECS.',I10, + 1 ' WORDS OF STORAGE USED.') + IF(PRINT.LT.4) WRITE(6,710) TIT + 710 FORMAT('1',120A1) + IF(PRINT.GE.4.AND.ITHROW.EQ.0) WRITE(6,720) + 720 FORMAT('1') +C +C ************** LOOP OVER JTOT VALUES BEGINS HERE. ****************** +C + DO 990 JTOT=JTOTL,JTOTU,JSTEP + IF(PRINT.GE.1 .AND. PRINT.LE.4) WRITE(6,730) JTOT + 730 FORMAT(/' ANGULAR MOMENTUM JTOT =',I4/2X,7('****')) + THETA=THETLW+THETST*DBLE(JTOT) +C +C *************** LOOP OVER SYMMETRY BLOCKS BEGINS HERE ************** +C + DO 980 M=1,MXPAR + PHI=PHILW+PHIST*DBLE(M-1) + IF(MSET.GT.0.AND.(M.LT.MSET.OR.M.GT.MHI)) GO TO 980 + IF (IRSTRT.GE.2.AND.JTOT.EQ.JTOTL.AND.M.LT.MRSTRT) THEN + WRITE(6,736) M,IRSTRT + 736 FORMAT(' *** SKIPPING MVALUE =',I3,' DUE TO IRSTRT =',I3) + GO TO 980 + ENDIF + IF(PRINT.LT.4) GOTO 760 + IF(ITHROW.NE.0) WRITE(6,710) TIT + IF(ITHROW.EQ.0) WRITE(6,740) TIT + 740 FORMAT(/' ',120A1) + WRITE(6,750) JTOT,M + 750 FORMAT(/' TOTAL ANGULAR MOMENTUM, JTOT =',I5,' SYMMETRY', + 1 ' BLOCK =',I4) + 760 CONTINUE +C +C CHOOSE BASIS FUNCTIONS +C + CALL BASE (JTOT,X(IXJLEV),N,X,X,CINT,X,X,X,X,MXLAM,NPOTL,X(ILAM), + 1 X,WGHT,IEXCH,THETA,PHI,M,.TRUE.,EFIRST,NLEV,PRINT) +C +C MOLD IS A REMNANT OF THE PREVIOUS "PARITY CASE" PROCESSING. +C MXP IS USED IN CONVERGENCE CHECKING, MOLD IS PASSED TO PRBR +C + MOLD=-M + IF(M.EQ.MXPAR.AND.N.LE.0) MOLD=0 + MXP=MAX0(MXP,IABS(MOLD)) + IF(M.EQ.MXPAR) MOLD=0 +C +C N IS THE NUMBER OF BASIS FUNCTIONS +C SKIP THIS JTOT,M IF NO CHANNELS +C +C IF(N.LE.0) GOTO 980 <<- SG: FIXES ISIGU BUG + IF(N.LE.0) GOTO 770 + NSQ = N*N +C +C ALLOCATE STORAGE FOR COUPLED EQUATION SOLVER. +C +C ALLOCATE STORAGE COMMON TO ALL SCATTERING. . . +C IS0-IS9 ARE SREAL,SIMAG,K-MATRIX,VL,IV,EINT,CENT,WVEC,L,NBASIS +C NOTE THAT INTEGER ARRAYS OF LENGTH N ARE NOT REDUCED BY NIPR +C IC1 IS IXNEXT AFTER ALLOCATIONS OF BASIN, POTENL, OUTINT ... + ISJ=IC1 + IS0=ISJ+N + IS1=IS0+NSQ + IS2=IS1+NSQ + IS3=IS2+NSQ + NV=N*(N+1)/2 + IF(IVLU.EQ.0) NV=NV*NPOTL + IS4=IS3+NV + IS5=IS4 + IF(IVLFL.GT.0) IS5=IS4+(NV+NIPR-1)/NIPR + IS6=IS5+N + IS7=IS6+N + IS8=IS7+N + IS9=IS8+N + IXNEXT=IS9+N +C +C SET UP SOME STORAGE POINTERS FOR LATER USE IN CONVRG +C + IF(ICONV.GT.0) THEN + IS10=IXNEXT + IS11=IS10+NSQ + IXNEXT=IS11+NSQ + ENDIF + IC2=IXNEXT + CALL CHKSTR(NUSED) +C IXNEXT/IC2 REFLECT STORAGE ALWAYS NEEDED FOR THIS JTOT,PARITY. +C +C SET UP BASIS FUNCTIONS IN ALLOCATED STORAGE +C + CALL BASE(JTOT,X(IXJLEV),N,X(ISJ),X(IS8),CINT,X(IS5),X(IS6), + 1 X(IS3),X(IS4),MXLAM,NPOTL,X(ILAM),X(IS7),WGHT,IEXCH,THETA, + 2 PHI,M,.FALSE.,EFIRST,NLEV,PRINT) +C +C CHECK THAT RMAX IS BEYOND CENTRIFUGAL BARRIER +C + CALL FINDRX(ENERGY,X(IS5),X(IS6),NPR,N,CINT,RMAX,RSTOP, + 1 NOPMAX,IRXSET,PRINT) + IF(INTFLG.EQ.5) RVIVAS=RSTOP + RSTART=RMIN +C +C ****************** LOOP OVER ENERGIES BEGINS HERE ****************** +C + 770 NELOOP=(NNRG+NNRGPG-1)/NNRGPG + JHI=0 + ICODE=0 + ALDONE=.TRUE. + DO 966 IEL=1,NELOOP + JLO=JHI+1 + JHI=MIN(JHI+NNRGPG,NNRG) +C +C SEE WHETHER THIS BLOCK OF ENERGIES CAN BE SKIPPED +C + LCALC=.FALSE. + DO 775 J=JLO,JHI + IF(IECONV(J).LT.0 .AND. IECONV(J).GT.-2*MXP) THEN + WRITE(6,772) JTOT,J + 772 FORMAT(/' * * * WARNING. JTOT =',2I5,'-TH ENERGY PREVIOUSLY ', + 1 'FAILED TO CONVERGE.') + LCALC=.TRUE. + ELSEIF(IECONV(J).EQ.0) THEN + LCALC=.TRUE. + ELSEIF(IECONV(J).GT.0) THEN + IF(JTOTU.LT.999999 .OR. IECONV(J).LT.NCAC*MXP) LCALC=.TRUE. + ENDIF + 775 CONTINUE +C + IF(.NOT.LCALC) GOTO 966 + ALDONE=.FALSE. + DO 960 J=JLO,JHI + IF(N.LE.0) THEN + CALL OUTSIG(ISIGU,M,MXPAR,J,ENERGY,MINJT,MAXJT,X(IOUT)) + GOTO 960 + ENDIF +C +C IF THIS IS A PRESSURE BROADENING CALC AND THIS S-MATRIX +C WILL NOT BE USED, SKIP IT +C + IF(IFLS.GT.0 .AND. IFEGEN.GE.2) THEN + CALL PRBCNT(J,X(ISJ),N,IUSE) + IF(IUSE.EQ.0) THEN + LWARN=.TRUE. + IF(PRINT.GE.4) WRITE(6,777) JTOT,M,J,ENERGY(J) + 777 FORMAT(/' ****** S MATRIX FOR JTOT =',I5,' M =',I4,3X, + 1 'ENERGY(',I3,') =',F18.9,/9X,'WILL NOT BE USED ', + 2 'IN PRESSURE BROADENING CALCULATION: SKIPPING') + IF(IECONV(J).GE.0) IECONV(J)=IECONV(J)+1 + CALL OUTSIG(ISIGU,M,MXPAR,J,ENERGY,MINJT,MAXJT,X(IOUT)) + GOTO 960 + ENDIF + ENDIF +C + IF (IRSTRT.EQ.3.AND.JTOT.EQ.JTOTL.AND.M.EQ.MRSTRT.AND.J.LT.IERST) + 1 GO TO 960 + ETOT=ENERGY(J) + ERED=ETOT*CINT + IF(ICODE.EQ.0) THEN + EFIRST=ERED + ICODE=1 + ENDIF + ESHIFT=ERED-EFIRST +C +C ICODE CONTROLS WHETHER POTENTIAL INFORMATION IS READ FROM CHANNEL +C ICODE=1 CALCULATES INFORMATION AND STORES IT +C ICODE=2 (SET AFTER 1ST ENERGY) READS STORED INFORMATION +C + IF(PRINT.GE.4) THEN + IF(ITHROW.EQ.0) THEN + WRITE(6,740) TIT2 + ELSE + WRITE(6,710) TIT2 + ENDIF + WRITE(6,780) JTOT,M,J,ETOT + 780 FORMAT(/' JTOT =',I5,' SYMMETRY BLOCK =',I4,' ENERGY(', + 1 I3,') =',F18.9,' (1/CM)') + ENDIF +C +C FOR SURFACE SCATTERING AT SUBSEQUENT ENERGY, +C GET CORRESPONDING THETA FOR PRINTING +C + IF(ITYPE.EQ.8 .AND. J.NE.1) THEN + SINTH=SIN(THETA*PI/180.D0) + SINTH=SINTH**2*ENERGY(1)/ETOT + IF(SINTH.GT.1.D0) GOTO 960 + THETJ=ASIN(SQRT(SINTH))*180.D0/PI + WRITE(6,795) J,ETOT,THETJ + 795 FORMAT(/' NOTE: K VECTORS PARALLEL TO SURFACE WERE ', + 1 'CALCULATED FOR ENERGY(1)'/' SUBSEQUENT ENERGY(',I3,') =', + 2 F10.4,' CORRESPONDS TO THETA =',F10.4,' DEGREES') + ENDIF +C +C TEMPORARY STORAGE FOR HEADER, FINDRM +C + IT1=IXNEXT + IT2=IT1+MXLAM + IT3=IT2+N + IT4=IT3+N + IT5=IT4+N + IXNEXT=IT5+N + CALL CHKSTR(NUSED) +C + CALL HEADER(X(IS1),X(IS2),N,NSQ,X(IT1),X(IS3),X(IS4),X(IS5), + 1 X(IS6),X(IT2),MXLAM,NPOTL,ICODE,ISAV,EFIRST) +C + IF(ICODE.EQ.1 .AND. IRMSET.GT.0) THEN +C FOR IRMSET > 0 OPTION, CHOOSE APPROPRIATE RMIN + RSTART=RMIN + CALL FINDRM(X(IS1),N,RSTART,RTURN,IK,X(IT1),X(IS3),X(IS4),ERED, + 1 X(IS5),X(IS6),RMLMDA,X(IT2),X(IT3),X(IT4),X(IT5),MXLAM,NPOTL, + 2 IRMSET,ITYPE,PRINT) + IF(RVFAC.NE.0.D0) THEN + RMID=RVFAC*RTURN + IF(PRINT.GE.3.AND.RSTOP.GT.RMAX) WRITE(6,799) RSTOP,RMAX + 799 FORMAT(' RMID OBTAINED FROM RTURN EVEN THOUGH RSTOP.GT.RMAX', + 1 2F8.2) + IF(PRINT.GE.3) WRITE(6,800) RMID,RVFAC + 800 FORMAT(/' RMID =',F7.2,' OBTAINED FROM RVFAC =',F6.3) + ENDIF + ELSE + RTURN=RMIN + IK=1 + ENDIF +C +C RESET IXNEXT TO RECOVER TEMPORARY STORAGE FROM HEADER AND FINDRM +C + IXNEXT=IT1 +C +C SOLVE COUPLED EQUATIONS. +C PROPAGATORS ARE CALLED FROM SUBROUTINE STORAG +C + CALL STORAG(INTFLG,N,MXLAM,NV,NPOTL, + 1 ISJ,IS0,IS1,IS2,IS3,IS4,IS5,IS6,IS7,IS8,IS9, + 2 ESHIFT,NOPMAX,DEEP,IK,ICODE,PRINT,NUMDER) +C + CALL GCLOCK(TJTIME) + TTIME=(TJTIME-TITIME) + TITIME=TJTIME +C + IF(NOPEN.GT.0) THEN +C RESET ICODE TO ALLOW "SUBSEQUENT ENERGY" CALCULATIONS + ICODE=2 + ELSE + IF(PRINT.GE.4) WRITE(6,900) JTOT,M,J,ETOT,TTIME + 900 FORMAT(/' ****** NO OPEN CHANNELS FOR JTOT =',I5,3X, + 1 'M =',I4,' ENERGY(',I3,') =',F18.9,10X,'STEP TIME =', + 2 F6.2,' SECS') + IF(IECONV(J).GE.0) IECONV(J)=IECONV(J)+1 + GOTO 960 + ENDIF +C +C FORCE IRSTRT=0 SO THAT ISAVEU WILL BE UPDATED. + IRSTRX=0 +C AUG 95 (SG) ADDED N TO PAREMETER LIST SO IT CAN BE PRINTED + CALL OUTPUT(JTOT,X(IS9),X(ISJ),X(IS8),X(IS7),X(IS0),X(IS1), + 1 X(IS2),CONV,NOPEN,M,MXPAR,WGHT,IEXCH,J,RM,PRINT,TTIME, + 2 ENERGY,X(IOUT),X(IXJLEV),ISST,IECONV,MINJT,MAXJT, + 3 NLEV,NQN,OTOL,DTOL,KSAVE,ISIGU,IPARTU,ISAVEU,ISIGPR,IRSTRX,N) +C + IF(ICONV.GT.0) CALL CONVRG(J,X(IS0),X(IS1),X(IS10),X(IS11)) + IF(IECONV(J).LT.0 .OR. IFLS.LE.0) GOTO 940 +C +C TEMPORARY STORAGE FOR PRBR -- THESE ARE INTEGERS, COULD USE NIPR + IT1=IXNEXT + IT2=IT1+N + IT3=IT2+N + IT4=IT3+N + IXNEXT=IT4+N + CALL CHKSTR(NUSED) + CALL PRBR(JTOT,MOLD,NOPEN,J,RM, + 1 X(IS9),X(ISJ),X(IS8),X(IS7), + 2 X(IS0),X(IS1),X(IT1),X(IT2),X(IT3),X(IT4), + 3 X(IXJLEV),MXPAR,WGHT,PRINT,ILSU) +C RECOVER TEMPORARY STORAGE ... + IXNEXT=IT1 +C + 940 IF(PRINT.GE.5) WRITE(6,950) JTOT,M,J,ETOT,TTIME + 950 FORMAT(/' FINISHED JTOT =',I5,' M =',I4,' ENERGY(',I3, + 1 ') =',F18.9,10X,'STEP TIME =',F8.2,' SECS') +C + 960 CONTINUE +C +C RESONANCE SEARCH OPTION - GENERATE NEXT 5 ENERGIES +C + IF(ISRCH.EQ.0) GOTO 964 + CALL NEXTE(ENERGY(JLO),EPSM,ENEW,DNRG,KSAVE) + IF(JHI.EQ.NNRG) GOTO 964 + IF(ENEW.LE.0.D0) GOTO 1000 + JST=JHI+1 + JND=JHI+5 + WRITE(6,600) NNRG + DO 962 JJ=JST,JND + ENERGY(JJ)=ENEW+(JJ-JST)*DNRG + ENEV=ENERGY(JJ)/8065.541D0 + WRITE(6,620) JJ,ENERGY(JJ),ENEV + 962 CONTINUE + 964 CONTINUE +C + 966 CONTINUE +C +C ******************** END OF LOOP OVER ENERGIES ********************* +C + IF(ALDONE) THEN + WRITE(6,968) DTOL,OTOL,NCAC + 968 FORMAT(///' CALCULATION TERMINATED BY CONVERGENCE OF TOTAL ', + 1 'CROSS SECTIONS.'//' DIAGONAL AND OFF-DIAGONAL TOLERANCES ', + 2 'WERE ',2F9.5,' NCAC =',I3) + GOTO 1000 + ENDIF +C + IF(PRINT.GE.2 .AND. PRINT.LT.5) WRITE(6,970) + 970 FORMAT(/) +C RESTORE ERED TO FIRST ENERGY VALUE. + ERED = EFIRST + 980 CONTINUE +C +C ****************** END OF LOOP OVER SYMMETRY BLOCKS **************** +C + IF(IFLS.GT.0) CALL PRBOUT(JSTEP) + 990 CONTINUE +C +C ******************** END OF LOOP OVER JTOT VALUES ****************** +C +C END OF RUN BOOKKEEPING +C + 1000 CALL OUTPCH(X(IOUT),ENERGY,NNRG,MINJT,MAXJT,ISIGPR,LABL,ISIGU, + 1 LWARN) + IF(IFLS.GT.0) WRITE(6,710) TIT + IF(IFLS.GT.0) CALL PRBOUT(JSTEP) + IF(IFLS.GT.0) CALL DACLOS + CALL GCLOCK(TLAST) + TOTIME=TLAST-TFIRST +C MAKE SURE WE HAVE NUSED FOR KSAVE BY CALLING CHKSTR + CALL CHKSTR(NUSED) + IF(KSAVE.GT.0) WRITE(KSAVE,1010) TOTIME,TTIME,NUSED + 1010 FORMAT(/' TOTAL CPU =',F9.2,' SECS LAST CYCLE =', + 1 F8.2,' SECS NUSED =',I8) +C +C *** IOS CALCULATION (IOSFLG.GT.0) REJOINS CODE BELOW +C ASCERTAIN 'HIGH-WATER' MARK IN STORAGE FROM CHKSTR. +C MX MAY HAVE BEEN REDUCED, SO USE MXSAVE FOR ALLOCATED STORAGE +C + 1020 CALL CHKSTR(NUSED) + WRITE(6,1030) IPROGM,PDATE,TOTIME,NUSED,MXSAVE + 1030 FORMAT(///' ',8('----MOLSCAT----')/' |',120X,'|'/' |',13X, + 1 'COUPLED CHANNEL MOLECULAR SCATTERING PROGRAM OF J. M. HUTSON ', + 2 'AND S. GREEN, VERSION',I3,1X,A8,13X,'|'/ + 3 ' |',120X,'|'/' |',13X,'THIS RUN USED',F11.2,' CPU SECS ', + 4 'AND',I10,' OF THE ALLOCATED',I10,' WORDS OF STORAGE',14X, + 5 '|'/' |',120X,'|'/' ',8('----MOLSCAT----') ) + IF(LASTIN.EQ.0) GOTO 100 + 1040 RETURN + END + SUBROUTINE AIRPRP (Z, W, TMAT, VECNOW, VECNEW, + + EIGOLD, EIGNOW, HP, Y1, Y2, CC, Y4, XF, REND, DRNOW, EN, + + TOLAI, POWR, ESHIFT, NCH, ITWO, IREAD, IWRITE, IPRINT, + $ ISCRU, P, MXLAM, VL, IV, RMLMDA, EINT, CENT, NPOTL) +C +* AIRY ZEROTH-ORDER PROPAGATOR FROM R=XF TO R=REND +* FOR REFERENCE SEE M. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS +* J. CHEM. PHYS. 81, 4510 (1984) +* AND M. ALEXANDER AND D. MANOLOPOULOS, "A STABLE LINEAR +* REFERENCE POTENTIAL ALGORITHM FOR SOLUTION ..." +* J. CHEM. PHYS. 86, 2044 (1987) +* AUTHOR: MILLARD ALEXANDER +* CURRENT REVISION DATE: 4-FEB-1991 +* ---------------------------------------------------------------------- +* ADAPTED TO MOLSCAT 4/91 BY TRP@NASAGISS +* ADAPTED TO MOLSCAT VERSION 11 BY JMH, JUN 92 +*----------------------------------------------------------------------- +* DEFINITION OF VARIABLES IN CALL LIST: +* Z: MATRIX OF MAXIMUM DIMENSION NCH*NCH +* ON ENTRY Z CONTAINS THE INITIAL Z-MATRIX AT R=XF +* ON RETURN Z CONTAINS THE Z-MATRIX AT R=REND +* W, TMAT, VECNOW +* , VECNEW: SCRATCH MATRICES OF DIMENSION AT LEAST NCH*NCH +* EIGOLD, EIGNOW +* , HP, Y1, Y2 +* , CC, Y4: SCRATCH VECTORS OF DIMENSION AT LEAST NCH +* XF: ON ENTRY: CONTAINS INITIAL VALUE OF INTERPARTICLE D +* ON EXIT: CONTAINS FINAL VALUE OF INTERPARTICLE DIS +* THIS IS EQUAL TO REND IF NORMAL TERMINATI +* OTHERWISE AN ERROR MESSAGE IS PRINTED +* DRNOW: ON ENTRY: CONTAINS INITIAL INTERVAL SIZE +* ON EXIT: CONTAINS FINAL INTERVAL SIZE +* EN: COLLISION ENERGY IN ATOMIC UNITS +* TOLAI: PARAMETER TO DETERMINE STEP SIZES +* IF TOLAI .LT. 1, THEN ESTIMATED ERRORS ARE USED TO +* DETERMINE NEXT STEP SIZES FOLLOWING THE PROCEDURE O +* IN M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGOR +* IF TOLAI .GE. 1, THEN STEP SIZES ARE CONTROLLED BY +* ALGORITHM: DRNEXT = TOLAI * DRNOW +* POWR: POWER AT WHICH STEP SIZES INCREASE +C +C +* LOGICAL VARIABLES: +* ISYM: IF .TRUE., PROPAGATION ASSUMES SYMMETRY OF Y MATRIX +* ---------------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION (A-H, O-Z) + LOGICAL ISYM + INTEGER I, IEND, IERR, ITWO, IZERO, KSTEP, MAXSTP, + : NCH, NPT, NSKIP +* REAL CDIAG, CMAX, COFF, DRFIR, DRMID, DRNOW, EN, ESHIFT, FACT, +* : ONE, POWR, REND, RLAST, RMIN, RNEW, RNEXT, RNOW, ROLD, +* : SPCMN, SPCMX, TOLAI, XF, XLARGE, ZERO +* REAL CC, EIGNOW, EIGOLD, HP,Y1, Y2, Y4 +* REAL TMAT, VECNEW, VECNOW, W, Z + EXTERNAL CORR, TRNSFM, OUTMAT, POTENT, DAXPY, DCOPY, + : SYMINV, SPROPN, DSCAL, TRNSP, WAVEIG +* MATRIX DIMENSIONS (ROW DIMENSION = NCH, MATRICES STORED COLUMN BY CO + DIMENSION Z(1), W(1), TMAT(1), VECNOW(1), VECNEW(1) +* VECTORS DIMENSIONED NCH + DIMENSION EIGOLD(1), EIGNOW(1), HP(1), Y1(1), Y2(1), CC(1), Y4(1) + DIMENSION P(1),VL(1),IV(1),EINT(1),CENT(1) +C + DATA IZERO, IONE, ZERO, ONE /0, 1, 0.D0, 1.D0/ + DATA ISYM /.TRUE./ +C +* ---------------------------------------------------------------------- +C + ERED = EN + RMIN = XF + SPCMX = 0.D0 + SPCMN = 0.D0 + IF (ITWO .GT. 0) GO TO 60 + SPCMN = REND - RMIN +* DETERMINE LOCAL WAVEVECTORS AT RMIN TO USE IN ESTIMATING SECOND DERIV +* HP AND Y1 ARE USED AS SCRATCH VECTORS HERE + CALL WAVEIG (W, EIGOLD, HP, Y1, RMIN, NCH, P, MXLAM, VL, IV, + 1 RMLMDA, ERED, EINT, CENT, NPOTL) +* LOCAL WAVEVECTORS AT RMIN ARE RETURNED IN EIGOLD + DRFIR = DRNOW + DRMID = DRNOW * 0.5D0 + RLAST = XF + ROLD = XF + RNOW = RLAST + DRMID + RNEXT = RLAST + DRNOW +* DEFINE LOCAL BASIS AT RNOW AND CARRY OUT TRANSFORMATIONS +* VECNEW IS USED AS SCRATCH MATRIX AND Y1 IS USED AS SCRATCH VECTOR HER + CALL POTENT (W, VECNOW, VECNEW, EIGNOW, HP, Y1, + + RNOW, DRNOW, EN, XLARGE, NCH, + $ P, MXLAM, VL, IV, RMLMDA, ERED, EINT, CENT, NPOTL) +* VECNOW IS TRANSFORMATION FROM FREE BASIS INTO LOCAL BASIS +* IN FIRST INTERVAL +* E.G. P1=VECNOW ; SEE EQ.(23) OF +* M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ..." +* STORE VECNOW IN TMAT + CALL DCOPY (NCH*NCH, VECNOW, 1, TMAT, 1) +* DETERMINE APPROXIMATE VALUES FOR DIAGONAL AND OFF-DIAGONAL +* CORRECTION TERMS + CALL CORR (EIGNOW, EIGOLD, HP, DRNOW, DRMID, XLARGE, CDIAG, + : COFF, NCH) + MAXSTP = ( (REND-XF) / DRNOW ) * 5 + XF = REND + IF (IPRINT.GT.40) THEN + WRITE (6, 40) +40 FORMAT(/' ** AIRY PROPAGATION (NO DERIVATIVES):') + WRITE (6, 50) +50 FORMAT(' STEP RNOW', 5X, 5HDRNOW, 5X, 5HCDIAG, 6X, 4HCOFF) + END IF +60 IEND = 0 + IF (ITWO .LT. 0) GO TO 70 + IF (ITWO .EQ. 0) WRITE(ISCRU) MAXSTP + IF (ITWO. GT. 0) READ(ISCRU) MAXSTP +* WRITE OR READ RELEVANT INFORMATION + CALL OUTMAT (TMAT, EIGOLD, HP, ESHIFT, DRNOW, RNOW, + : NCH, NCH, ITWO, ISCRU) +C +C +* START AIRY PROPAGATION +C +* ---------------------------------------------------------------------- + 70 DO 200 KSTEP = 1, MAXSTP + NSTEP=KSTEP +C +* TRANSFORM LOG-DERIV MATRIX FROM LOCAL BASIS IN LAST INTERVAL TO +* LOCAL BASIS IN PRESENT INTERVAL. SEE EQ.(23) OF +* M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ..." +* W IS USED AS SCRATCH MATRIX HERE, AND Y1 IS SCRATCH ARRAY +C + CALL TRNSP ( TMAT, NCH) + CALL TRNSFM ( TMAT, Z, W, NCH, .FALSE., ISYM ) +C +* TMAT IS NO LONGER NEEDED +* SOLVE FOR LOG-DERIVATIVE MATRIX AT RIGHT-HAND SIDE OF +* PRESENT INTERVAL. THIS USES NEW ALGORITHM OF MANALOPOULOS AND ALEXAN +* NAMELY +* (N) (N) -1 (N) (N) +* Z = - Y [ Y + Z ] Y + Y +* N+1 2 1 N 2 4 +* WHERE Y , Y , AND Y ARE THE (DIAGONAL) ELEMENTS OF THE "IMBEDDING +* 1 2 4 +* PROPAGATOR DEFINED IN ALEXANDER AND MANOLOPOULOS +* DETERMINE THESE DIAGONAL MATRICES FOR PROPAGATION OF LOG-DERIV MATRIX +* EQS. (38)-(44) OF M. ALEXANDER AND D. MANOLOPOULOS, "A STABLE LINEAR +* REFERENCE POTENTIAL ALGORITHM FOR SOLUTION ..." +C + CALL SPROPN ( DRNOW, EIGOLD, HP, Y1, Y4, Y2, NCH) +C +* SET UP MATRIX TO BE INVERTED +* NSKIP IS SPACING BETWEEN DIAGONAL ELEMENTS OF MATRIX STORED COLUMN BY +C + NSKIP = NCH + 1 + CALL DAXPY (NCH, ONE, Y1, 1, Z, NSKIP) +C +* INVERT (Y + Z ) +* 1 N +C + CALL SYMINV (Z, NCH, NCH, IERR) + CALL DSYFIL ('U', NCH, Z, NCH) + IF (IERR .GT. NCH) THEN + WRITE (6, 80) +80 FORMAT (' *** INSTABILITY IN SYMINV IN AIRPRP.') + STOP + END IF +C +* -1 +* EVALUATE - Y ( Y + Z ) Y +* 2 1 N 2 +* IN THE NEXT LOOPS EVALUATE THE FULL, RATHER THAN LOWER TRIANGLE +C + NPT = 1 + DO 85 I = 1, NCH + FACT = Y2(I) + CALL DSCAL (NCH, FACT, Z(NPT), 1) + NPT = NPT + NCH +85 CONTINUE +* -1 +* Z NOW CONTAINS ( Y + Z ) Y , THIS IS G(N-1,N) IN THE LOCAL BASI +* 1 N 2 +C + DO 110 I = 1, NCH + FACT = - Y2(I) + CALL DSCAL (NCH, FACT, Z(I), NCH) +110 CONTINUE +C +* ADD ON Y +* 4 + CALL DAXPY (NCH, ONE, Y4, 1, Z, NSKIP) +C + IF (ITWO .GT. 0) GO TO 160 +C +C +* OBLIGATORY WRITE OF STEP INFORMATION IF DEVIATIONS FROM LINEAR +* POTENTIAL ARE UNUSUALLY LARGE +* THIS IS ONLY DONE IF TOLAI .LT. 1, IN WHICH CASE THE LARGEST CORRECTI +* IS USED TO ESTIMATE THE NEXT STEP +C + IF (TOLAI .LT. 1.) THEN + CMAX = MAX (CDIAG, COFF) + IF (CMAX .GT. (5. * TOLAI)) THEN + WRITE (6,125) +125 FORMAT + : (' ** ESTIMATED CORRECTIONS LARGER THAN 5*TOLAI IN AIRPRP') + IF (KSTEP .EQ. 1) THEN + WRITE (6, 130) +130 FORMAT (' THE INITIAL VALUE OF DRNOW (SPAC*FSTFAC) IS', + : ' PROBABLY TOO LARGE') + ELSE + WRITE (6, 140) +140 FORMAT + : (' CHECK FOR DISCONTINUITIES OR UNPHYSICAL OSCILLATIONS', + : /,' IN YOUR POTENTIAL') + END IF + IF (IPRINT.LT.41) THEN + WRITE (6, 50) + WRITE (6,150) KSTEP, RNOW, DRNOW, CDIAG, COFF + END IF + END IF + END IF +C +C +* WRITE OUT INFORMATION ABOUT STEP JUST COMPLETED +C + IF (IPRINT.GT.40) THEN + WRITE (6,150) KSTEP, RNOW, DRNOW, CDIAG, COFF +150 FORMAT (I6, 4E10.3) + END IF +C +C +* GET SET FOR NEXT STEP +C +160 IF (IEND .EQ. 1) GO TO 250 + IF (ITWO .GT. 0) GO TO 180 +C +C +* IF TOLAI .LT. 1, PREDICT NEXT STEP SIZE FROM LARGEST CORRECTION +C + IF (TOLAI .LT. 1.) THEN +C +* NOTE THAT THE FOLLOWING STATEMENT IS SLIGHTLY DIFFERENT FROM EQ. (30 +* OF M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ... AND THA +* THE STEP-SIZE ALGORITHM IS ONLY APPROXIMATELY RELATED TO ANY REAL +* ESTIMATE OF THE ERROR COFF AND CDIAG SHOULD BE APPROXIMATELY TOLAI, S +* FROM EQ. (27): +* DRNOW(AT N+1) = (12 TOLAI/KBAR(N+1)W(N+1)-TILDA')**(1/3) +* WHICH IS APPROXIMATELY = (12 TOLAI/KBAR(N)W(N)-TILDA')**(1/3) +* = ((12 COFF/KBAR W-TILDA') (TOLAI/COFF))**(1/3 +* = DRNOW(AT N) (TOLAI/COFF)**(1/3) +* OR FROM EQ. (29): +* DRNOW = DRNOW (TOLAI/CDIAG)**(1/3) +* THEN, USING THE LARGER ERROR AND ALLOWING POW TO VARY: +C +CSG>> + FACTOR=(TOLAI/CMAX) ** (1./POWR) +CSG LIMIT INCREMENT/DECREMENT FOR STABILITY ... + IF (FACTOR.GT.2.D0) FACTOR=2.D0 + IF (FACTOR.LE.0.1D0) FACTOR=1.D-1 + DRNOW = DRNOW * FACTOR +CSG<< DRNOW = DRNOW * (TOLAI/CMAX) ** (1. / POWR) + ELSE +C +* IF TOLAI .GE. 1, THEN +* MINIMUM STEP SIZE IS FIRST INTERVAL WIDTH +C + IF (KSTEP .EQ. 1) SPCMN = DRNOW +C +* AND NEXT STEP SIZE IS TOLAI * PRESENT STEP SIZE +C + DRNOW = TOLAI * DRNOW + END IF +C +* DRNOW IS STEP SIZE IN NEXT INTERVAL +C + RLAST = RNEXT + RNEXT = RNEXT + DRNOW + IF (RNEXT .LT. REND) GO TO 170 + IEND = 1 + RNEXT = REND + DRNOW = RNEXT - RLAST +170 RNEW = RLAST + 0.5D0 * DRNOW + IF (KSTEP .GT. 1 .AND. IEND .NE. 1) THEN + IF (TOLAI .LT. 1) THEN + IF (DRNOW .LT. SPCMN) SPCMN = DRNOW + END IF + IF (DRNOW .GT. SPCMX) SPCMX = DRNOW + END IF + DRMID = RNEW - RNOW +C +C +* RESTORE EIGENVALUES +C + CALL DCOPY (NCH, EIGNOW, 1, EIGOLD, 1) +C +* DEFINE LOCAL BASIS AT RNEW AND CARRY OUT TRANSFORMATIONS +* TMAT IS USED AS SCRATCH MATRIX AND Y1 IS USED AS SCRATCH VECTOR HERE +C + CALL POTENT (W, VECNEW, TMAT, EIGNOW, HP, Y1, + + RNEW, DRNOW, EN, XLARGE, NCH, + $ P, MXLAM, VL, IV, RMLMDA, ERED, EINT, CENT, NPOTL) +C +C +* DETERMINE MATRIX TO TRANSFORM LOG-DERIV MATRIX INTO NEW INTERVAL +* SEE EQ. (22) OF M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS +C + CALL DGEMUL(VECNEW, NCH, 'N', VECNOW, NCH, 'T', TMAT, NCH, + 1 NCH, NCH, NCH) + CALL DCOPY (NCH*NCH, VECNEW, 1, VECNOW, 1) +C +C +* RESTORE RADIUS VALUES +C + RNOW = RNEW +C +C +* DETERMINE APPROXIMATE VALUES FOR DIAGONAL AND OFF-DIAGONAL +* CORRECTION TERMS +C + CALL CORR (EIGNOW, EIGOLD, HP, DRNOW, DRMID, XLARGE, CDIAG, + : COFF, NCH) + IF (ITWO .LT. 0) GO TO 200 + IF (IEND .EQ. 1) RNOW = - RNOW +C +C +* WRITE OR READ RELEVANT INFORMATION +C +180 CALL OUTMAT (TMAT, EIGOLD, HP, ESHIFT, DRNOW, RNOW, + : NCH, NCH, ITWO, ISCRU) + IF (ITWO .EQ. 0) GO TO 200 +C +C +* NEGATIVE RNOW IS CUE FOR LAST STEP IN SECOND ENERGY CALCULATION +C + IF (RNOW .GT. 0.D0) GO TO 200 + RNOW = - RNOW + IEND = 1 +C +C +* GO BACK TO START NEW STEP +C +200 CONTINUE +C +C +* THE FOLLOWING STATEMENT IS REACHED ONLY IF THE INTEGRATION HAS +* NOT REACHED THE ASYMPTOTIC REGION IN MAXSTP STEPS +C + WRITE (6,210) MAXSTP, RNEXT +C + IF(IPRINT.GT.40) WRITE(6,210) MAXSTP,RNEXT +C +210 FORMAT (' *** AIRY PROPAGATION NOT FINISHED IN', I4, + : ' STEPS: R-FIN SET TO', F8.4,' ***',/) + XF = RNEXT +250 CONTINUE + IF (ITWO .LT. 0) GO TO 260 + CALL OUTMAT (VECNOW, EIGOLD, HP, ESHIFT, DRNOW, XF, NCH, + : NCH, ITWO, ISCRU) +C +C +* TRANSFORM LOG-DERIV MATRIX INTO FREE BASIS. TRANSFORMATION MATRIX IS +* JUST VECNOW-TRANSPOSE; SEE EQ.(24) OF M.H. ALEXANDER, "HYBRID QUANTUM +* SCATTERING ALGORITHMS ..." +260 CALL TRNSFM (VECNOW, Z, W, NCH, .FALSE., ISYM ) +C + IF (IPRINT.LT.41) GO TO 318 + IF (ITWO .LT. 0) WRITE (6,280) + IF (ITWO .EQ. 0) WRITE (6,290) + IF (ITWO .GT. 0) WRITE (6,300) +280 FORMAT (' ** AIRY PROPAGATION - FIRST ENERGY;', + : ' TRANSFORMATION MATRICES NOT WRITTEN') +290 FORMAT (' ** AIRY PROPAGATION - FIRST ENERGY;', + : ' TRANSFORMATION MATRICES WRITTEN') +300 FORMAT (' ** AIRY PROPAGATION - SECOND ENERGY;', + : ' TRANSFORMATION MATRICES READ') + WRITE (6,305) RMIN, REND, TOLAI, NSTEP + WRITE (6,310) SPCMN, SPCMX, POWR +305 FORMAT (' RBEGIN =', F7.3, ' REND =', F7.3, + : ' TOLAI =', 1PE8.1, ' NINTERVAL =', I3) +310 FORMAT (' DR-MIN =', F7.3, ' DR-MAX =', F8.3, + : ' POWER =', F4.1) +C + 318 CONTINUE + IF(IPRINT.LT.35) GO TO 319 + IF (ITWO .LT. 0) WRITE (6,280) + IF (ITWO .EQ. 0) WRITE (6,290) + IF (ITWO .GT. 0) WRITE (6,300) + 319 CONTINUE +C + IF(IPRINT.LT.3) GO TO 320 + WRITE (6, 315) RMIN, REND, SPCMN, SPCMX, NSTEP +315 FORMAT (' ** AIRY: RSTART =' ,F7.3,' REND =',F7.3, + : ' DRMIN =',F7.3, ' DRMAX =',F7.3,' NSTEP =', I4) +320 CONTINUE + RETURN + END + SUBROUTINE AIRYMP (X, FTHETA, FPHI, XMMOD, XNMOD) +* SUBROUTINE TO RETURN THE MODULI AND PHASES OF THE AIRY FUNCTIONS AND +* DERIVATIVES +* AUTHOR: MILLARD ALEXANDER +* CURRENT REVISION DATE: 23-SEPT-87 +* ---------------------------------------------------------------------- +* VARIABLES IN CALL LIST: +* X ARGUMENT OF AIRY FUNCTIONS +* FTHETA, XMMOD ON RETURN: CONTAIN THE (DOUBLE PRECISION) +* PHASE AND MODULUS OF AI(X) AND BI(X) ( +* BELOW). +* FPHI, XNMOD ON RETURN: CONTAIN THE (DOUBLE PRECISION) +* PHASE AND MODULUS OF AI'(X) AND BI'(X) +* BELOW). +* ---------------------------------------------------------------------- +* FOR NEGATIVE X +* ---------------------------------------------------------------------- +* THE MODULI AND PHASES ARE DEFINED BY +* AI(-X) = M(X) COS[THETA(X)] +* BI(-X) = M(X) SIN[THETA(X)] +* AI'(-X) = N(X) COS[PHI(X)] +* BI'(-X) = N(X) SIN[PHI(X)] +* IN OTHER WORDS +* 2 2 2 +* M(X) = SQRT[ AI(X) + BI(X) ] +* 2 2 2 +* N(X) = SQRT[ AI'(X) + BI'(X) ] +* THETA(X) = ATAN [ BI(X) / AI(X) ] +* PHI(X) = ATAN [ BI'(X) / AI'(X) ] +* TO DETERMINE THESE MODULI AND PHASES WE USE THE SUBROUTINE +* SCAIRY, WRITTEN BY D. MANOLOPOULOS (SEPT. 1986) +* THIS SUBROUTINE RETURNS THE FOLLOWING QUANTITIES: +* SCAI, SCBI, SCAIP, SCPIB, AND ZETA, WHERE +C FOR X .LT. -5.0 +C AI(X) = SCAI * COS(ZETA) + SCBI * SIN(ZETA) +C BI(X) = SCBI * COS(ZETA) - SCAI * SIN(ZETA) +C AI'(X) = SCAIP * COS(ZETA) + SCBIP * SIN(ZETA) +C BI'(X) = SCBIP * COS(ZETA) - SCAIP * SIN(ZETA) +C WHERE ZETA = (2/3) * (-X) ** (3/2) + PI/4 +C +C FOR -5.0 .LE. X .LE. 0.0 +C +C AI(X) = SCAI +C BI(X) = SCBI +C AI'(X) = SCAIP +C BI'(X) = SCBIP +C AND ZETA = 0 +* ---------------------------------------------------------------------- +* FOR POSITIVE X +* ---------------------------------------------------------------------- +* THE MODULI AND PHASES ARE DEFINED BY +* AI(X) = M(X) SINH[THETA(X)] +* BI(X) = M(X) COSH[THETA(X)] +* AI'(X) = N(X) SINH[PHI(X)] +* BI'(X) = N(X) COSH[PHI(X)] +* IN OTHER WORDS +* 2 2 2 +* M(X) = SQRT[ BI(X) - AI(X) ] +* 2 2 2 +* N(X) = SQRT[ BI'(X) - AI'(X) ] +* THETA(X) = ATANH [ AI(X) / BI(X) ] +* PHI(X) = ATANH [ AI'(X) / BI'(X) ] +* HERE THE THE EXPONENTIALLY SCALED AIRY FUNCTIONS +* AI(X), AI'(X), BI(X), BI'(X) ARE: +* AI(X) = AI(X) * EXP[ZETA] +* AI'(X) = AI'(X) * EXP[ZETA] +* BI(X) = BI(X) * EXP[-ZETA] +* BI'(X) = BI'(X) * EXP[-ZETA] +* TO DETERMINE THESE MODULI AND PHASES WE USE THE SUBROUTINE +* SCAIRY, WRITTEN BY D. MANOLOPOULOS (SEPT. 1986) +* THIS SUBROUTINE RETURNS THE FOLLOWING QUANTITIES: +* SCAI, SCBI, SCAIP, SCPIB, AND ZETA +* IN TERMS OF WHICH THE EXPONENTIALLY SCALED AIRY FUNCTIONS ARE DEFINED +* AI(X) = SCAI * EXP(-ZETA) +* BI(X) = SCBI * EXP(+ZETA) +* AI'(X) = SCAIP * EXP(-ZETA) +* BI'(X) = SCBIP * EXP(+ZETA) +* WHERE ZETA = (2/3) * X ** (3/2) +* +* ---------------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DOUBLE PRECISION X, FTHETA, FPHI, XMMOD, XNMOD, SCAI, + : SCBI, SCAIP, SCBIP, ZETA, RATIO + CALL SCAIRY (X, SCAI, SCBI, SCAIP, SCBIP, ZETA) + IF ( X .LE. 0.D0) THEN + XMMOD = SQRT( SCAI ** 2 + SCBI ** 2) + XNMOD = SQRT( SCAIP ** 2 + SCBIP ** 2) + FTHETA = ATAN2 (SCBI, SCAI) + FPHI = ATAN2 (SCBIP, SCAIP) + IF (X .LT. (-5.0D0) ) THEN + FTHETA = FTHETA - ZETA + FPHI = FPHI - ZETA + END IF + ELSE + XMMOD = SQRT( - SCAI ** 2 + SCBI ** 2) + XNMOD = SQRT( - SCAIP ** 2 + SCBIP ** 2) + RATIO = SCAI / SCBI + FTHETA = 0.5 * LOG ( (1.D0 + RATIO) / (1.D0 - RATIO) ) + RATIO = SCAIP / SCBIP + FPHI = 0.5 * LOG ( (1.D0 + RATIO) / (1.D0 - RATIO) ) + END IF + RETURN + END + SUBROUTINE ASROT(J,EVEC,H,EVAL,WKS,NH) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + LOGICAL TD,EVLIST + DIMENSION EVEC(NH,NH),H(NH,NH),EVAL(NH),WKS(NH) + DIMENSION WT(2),ELEVEL(1000),JLEVEL(4000),ISYM(10),ISYM2(10), + 1 ROTI(2) + COMMON /CMBASE/ A(2),B(2),C(2),DJ,DJK,DK,DT,ROTI, + 1 ELEVEL,EMAX,WT,SPNUC,NLEVEL,JLEVEL,JMIN,JMAX,JSTEP,ISYM,J2MIN, + 1 J2MAX,J2STEP,ISYM2,JHALF,IDENT,MXJL,MXEL + DATA EVLIST/.FALSE./ +C +C DO THE ACTUAL CALCULATION FOR A GIVEN J +C + ALPHA=0.5D0*(A(1)+B(1)) + BETA=C(1)-ALPHA + GAMMA=0.25D0*(A(1)-B(1)) + TD = A(1).EQ.B(1) .AND. B(1).EQ.C(1) +C + JJ=J*(J+1) + NK=J+J+1 + DO 100 IR=1,NK + KR=IR-J-1 + DO 100 IC=1,IR + KC=IC-J-1 + TERM=0.D0 + IF(KR.EQ.KC) THEN + TERM=ALPHA*DBLE(JJ)+BETA*DBLE(KC*KC) + 1 -DJ*DBLE(JJ*JJ)-DJK*DBLE(JJ*KC*KC)-DK*KC**4 + IF(TD) TERM=TERM+0.5D0*DT*DBLE(-3*JJ*(JJ-2)+30*(JJ-2)*KC*KC + 1 -35*KC*KC*(KC*KC-1)) + ELSEIF(KR-KC.EQ.2) THEN + KMID=(KR+KC)/2 + TERM=GAMMA*SQRT(DBLE((JJ-KR*KMID)*(JJ-KC*KMID))) + ELSEIF(KR-KC.EQ.4 .AND. TD) THEN + TERM=1.25D0*DT*SQRT(DBLE((JJ-KC*(KC+1))*(JJ-(KC+1)*(KC+2))) + 1 *DBLE((JJ-(KC+2)*(KC+3))*(JJ-(KC+3)*(KC+4)))) + ENDIF + H(IR,IC)=TERM + 100 CONTINUE + IFAIL=0 + CALL F02ABF(H,NH,NK,EVAL,EVEC,NH,WKS,IFAIL) +C + WRITE(6,603) J,(EVAL(IC),IC=1,NK) + 603 FORMAT('0 CALCULATED ROTATIONAL LEVELS FOR J =',I3,' ARE'/ + 1 (8X,9F12.5)) +C +C IF THE RAW EIGENVECTORS ARE DEGENERATE, THEY MAY NOT HAVE +C PROPER SYMMETRY. SEEK DEGENERATE SETS AND FORCE SYMMETRY ON THEM. +C ALSO PRINT SPHERICAL TOP SYMMETRY LABELS IF ANY DEGENERATE SETS +C ARE PRESENT. +C + CALL DMSYM(J,NK,EVAL,EVEC,H,WKS) +C + IF(EVLIST) THEN + WRITE(6,604) + 604 FORMAT('0 EIGENVECTOR COEFFICIENTS:') + DO 200 IR=1,NK + KR=IR-J-1 + WRITE(6,605) J,KR,(EVEC(IR,IC),IC=1,NK) + 605 FORMAT(2I4,9F12.8/(8X,9F12.8)) + 200 CONTINUE + ENDIF + RETURN + END + SUBROUTINE AXSCAT(N, NSQ, MXLAM, NPOTL, + 1 SR, SI, U, VL, IV, EINT, CENT, WVEC, L, NB, + 2 P, Y1, Y2, Y3, Y4, VECNOW, VECNEW, EIGOLD, EIGNOW, HP, + 3 ICODE, IPRINT) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C --------------------------------------------------------------- +C THIS IS TIM PHILLIP'S INTERFACE OF ALEXANDER HIBRIDON +C CODES TO MOLSCAT: SCATTERING CALC USING DAPROP AND THEN +C AIRPRP. ON EXIT SR AND SI CONTAIN THE S-MATRIX. +C SR IS USED INTERNALLY TO HOLD THE LOG DERIVATIVE MATRIX +C ICODE.EQ.2 FOR SUBSEQUENT ENERGIES. +C --------------------------------------------------------------- +C REORGANIZED BY SG (2/2/93): CORRECTS NSTEPS=0 PROBLEM, BUT +C ALSO CALCULATES SOMEWHAT DIFFERENT STEP SIZES FROM EARLIER CODE. +C --------------------------------------------------------------- +C +C DIMENSION STATEMENTS FOR ARGUMENT LIST +C + DIMENSION U(NSQ),Y1(N),Y2(N),Y3(N),Y4(N) + DIMENSION P(MXLAM),VL(2),IV(2),SR(NSQ),SI(NSQ), + & EINT(N),CENT(N),WVEC(N),L(N),NB(N) + DIMENSION VECNOW(NSQ),VECNEW(NSQ),EIGOLD(N),EIGNOW(N),HP(N) +C + LOGICAL IREAD,IWRITE, LLD,LAIRY +C +C COMMON BLOCKS TO COMMUNICATE WITH PROPAGATORS +C THE FOLLOWING VARIABLES FROM COMMON/DRIVE/ ARE USED WITH THIS +C PROPAGATOR: STEPS,RMIN,RMAX,ERED,RMLMDA,NOPEN,ISCRU,TOLHI,RMID, +C AND SOMETIMES DR +C + COMMON/DRIVE/STEST,STEPS,STABIL,CONV,RMIN,RMAX,XEPS,DR, + 1 DRMAX,RMID,TOLHI,RTURN,VTOL,ESHIFT,ERED,RMLMDA, + 2 NOPEN,JKEEP,ISCRU,MAXSTP +C + COMMON/HIBRIN/POWRX,DRAIRY,IABSDR +C +C SET UP TO USE UNIT (ISCRU) + IREAD = ICODE.EQ.2 .AND. ISCRU.GT.0 + IWRITE = ICODE.EQ.1 .AND. ISCRU.GT.0 +C --------------------------------------------------------------- + IF((.NOT.IREAD) .AND. IWRITE) THEN + ITWO = 0 + ELSE IF(IREAD .AND. (.NOT.IWRITE)) THEN + ITWO = 1 + ELSE IF((.NOT.IREAD) .AND. (.NOT.IWRITE)) THEN + ITWO = -1 + ELSE + WRITE(6,*) ' ILLEGAL IREAD/IWRITE COMBINATION ' + WRITE(6,*) ' BOTH SIMULTANEOUSLY TRUE ' + STOP + END IF +C-------------------------------------------------------------------- +C +C DECIDE WHICH CALCULATIONS TO DO. +C ON THE ASSUMPTION THAT RMIN.LT.RMAX THERE ARE THREE CASES +C 1) RMID.LE.RMIN.LT.RMAX +C 2) RMIN.LT.RMID.LT.RMAX +C 3) RMIN.LT.RMAX.LE.RMID +C CODE BELOW SETS FOLLOWING LLD LAIRY RSWTCH +C CASE 1 F T RMIN +C CASE 2 T T RMID +C CASE 3 T F RMAX +C INTEGRATION RANGES ARE THEN DAPROP: RMIN -> RSWTCH +C AIRY: RSWTCH -> RMAX +C-------------------------------------------------------------------- + RBEGIN=RMIN + REND=RMAX + LLD=RBEGIN.LT.RMID + LAIRY=RMID.LT.REND + RSWTCH=MIN(REND,RMID) + RSWTCH=MAX(RSWTCH,RBEGIN) +C +C CALCULATE WAVEVECTORS AND STEP SIZE + WMAX=0.D0 + NOPEN=0 + DO 20 I=1,N + DIF=ERED-EINT(I) + WVEC(I)=SIGN(SQRT(ABS(DIF)),DIF) + WMAX=MAX(WMAX,WVEC(I)) + NB(I)=I + IF (DIF.GT.0.D0) NOPEN=NOPEN+1 + 20 CONTINUE + IF (NOPEN.EQ.0) RETURN +C + IF (IREAD) GO TO 40 + PI=ACOS(-1.D0) + DRLD=PI/(WMAX*STEPS) + IF (IABSDR .EQ. 1 .AND. DR .GT. 0.D0) DRLD=DR + NSTEPS=(RSWTCH-RBEGIN)/DRLD + IF (IWRITE) WRITE (ISCRU) RBEGIN,RSWTCH,REND,DRLD,NSTEPS + GO TO 60 + 40 READ (ISCRU) RBEGIN,RSWTCH,REND,DRLD,NSTEPS + 60 CONTINUE +C +C SET REND FOR YTOK, AND RESET RSWTCH IN CASE WE DON'T CALL AIRPRP + RYON=REND + REND=RSWTCH + RSWTCH=RBEGIN +C + LLD=LLD .AND. NSTEPS.GT.0 + IF (LLD) THEN + RSWTCH=REND +C PROPAGATE LOG DERIVATIVE THROUGH FIRST SEGMENT. +C ISTART=0 REQUESTS INITIALIZATION OF LOG-DERIVATIVE MATRIX + ISTART=0 + CALL DAPROP(U, SR, N, + 1 RBEGIN, REND, NSTEPS, IREAD, IWRITE, ISCRU, + 2 Y1, Y2, Y3, Y4, + 3 P, VL, IV, ERED, EINT, CENT, RMLMDA, + 4 MXLAM, NPOTL, ISTART, NODES) +C ------------------------------------------------------------- + IF (IPRINT.GE.3) WRITE (6,1000) RBEGIN,RSWTCH,NSTEPS +1000 FORMAT(' AXSCAT. LOG DERIVATIVE MATRIX INTEGRATED FROM ', + & F12.4,' TO ',F12.4,' IN ',I6,' STEPS.') + ELSE +C INITIALIZE LOG-DERIVATIVE MATRIX IF DAPROP NO CALLED + DO 42 I=1,NSQ +42 SR(I)=0.D0 + DO 43 I=1,NSQ,N+1 +43 SR(I)=1.D30 + IF (IPRINT.GE.3) WRITE (6,1010) +1010 FORMAT(' AXSCAT. DAPROP NOT CALLED: LOG DERIVATIVE MATRIX ', + & 'INITIALIZED.') + ENDIF +C +C USE AIRY PROPAGATOR FOR THE REMAINDER OF THE SCATTERING REGION +C + IF (.NOT.LAIRY) GO TO 41 + REND=RYON + DRA=DRLD + IF (DRAIRY .GT. 0.D0) DRA = DRAIRY + CALL AIRPRP(SR,U,SI,VECNOW,VECNEW,EIGOLD,EIGNOW,HP, + 1 Y1,Y2,Y3,Y4,RSWTCH, + 2 REND,DRA,ERED,TOLHI,POWRX,ESHIFT,N, + 3 ITWO,IREAD,IWRITE,IPRINT,ISCRU,P,MXLAM,VL,IV,RMLMDA, + 4 EINT,CENT,NPOTL) +C +C SORT CHANNELS BY ASYMPTOTIC ENERGY +C + 41 CONTINUE + IF (N.EQ.1) GO TO 100 + NM1=N-1 + DO 80 I=1,NM1 + IP1=I+1 + DO 80 J=IP1,N + IF (EINT(NB(I)).LE.EINT(NB(J))) GO TO 80 + IT=NB(I) + NB(I)=NB(J) + NB(J)=IT + 80 CONTINUE +C +C CALCULATE K AND S MATRICES +C + 100 CALL YTOK(NB,WVEC,L,N,NOPEN,Y1,Y2,Y3,Y4,SR,SI,U,REND) + CALL KTOS(U,SR,SI,NOPEN) + RETURN + END + SUBROUTINE BAS9IN(PRTP,IBOUND) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE + CHARACTER*8 PRTP(4),QNAME(10) + LOGICAL LEVIN,EIN,LCNT + DIMENSION ROTI(12),ELEVEL(1000),JLEVEL(4000), + 1 ISYM(10),ISYM2(10),WT(2) + DIMENSION JLEV(1),VL(1),IV(1),CENT(1),J(1),L(1),LAM(1) + COMMON/CMBASE/ROTI,ELEVEL,EMAX,WT,SPNUC,NLEVEL,JLEVEL, + 1 JMIN,JMAX,JSTEP,ISYM,J2MIN,J2MAX,J2STEP,ISYM2,JHALF,IDENT + 2 ,MXJL,MXEL +C +C BAS9IN IS CALLED ONCE FOR EACH SCATTERING SYSTEM (USUALLY ONCE +C PER RUN) AND CAN READ IN ANY BASIS SET INFORMATION NOT CONTAINED +C IN NAMELIST BLOCK &BASIS. IT MUST ALSO HANDLE THE FOLLOWING +C VARIABLES AND ARRAYS: +C +C PRTP SHOULD BE RETURNED AS A CHARACTER STRING DESCRIBING THE +C COLLISION TYPE +C IDENT CAN BE SET>0 IF A COLLISION OF IDENTICAL PARTICLES IS +C BEING CONSIDERED AND SYMMETRISATION IS REQUIRED. +C HOWEVER, THIS WOULD REQUIRE EXTRA CODING IN IDPART. +C IBOUND CAN BE SET>0 IF THE CENTRIFUGAL POTENTIAL IS NOT OF THE +C FORM L(L+1)/R**2; IF IBOUND>0, THE CENT ARRAY MUST BE +C RETURNED FROM ENTRY CPL9 +C + IBOUND=1 + PRTP(1)=' BODY-F' + PRTP(2)='IXED ATO' + PRTP(3)='M-DIATOM' + PRTP(4)=' ' + RETURN +C + ENTRY SET9(LEVIN,EIN,NLEV,JLEV,NQN,QNAME,MXPAR,NLABV) +C +C SET9 IS CALLED ONCE FOR EACH SCATTERING SYSTEM. IT SETS UP: +C MXPAR, THE NUMBER OF DIFFERENT SYMMETRY TYPES ("PARITY CASES") +C NLEVEL AND JLEVEL, UNLESS LEVIN IS .TRUE.; +C JLEV AND NLEV; +C ELEVEL, UNLESS EIN IS .TRUE. +C IF THE LOGICAL VARIABLES ARE .TRUE. ON ENTRY, THE CORRESPONDING +C QUANTITIES WERE INPUT EXPLICITLY IN NAMELIST BLOCK &BASIS. +C IF EIN IS .FALSE., THE MOLECULAR CONSTANTS MUST HAVE BEEN SUPPLIED +C IN THE &BASIS ARRAY ROTI: THE PROGRAMMER MAY USE THESE IN ANY WAY +C HE LIKES, BUT SHOULD OUTPUT THEM HERE FOR CHECKING. +C NOTE THAT JLEVEL CONTAINS JUST THE QUANTUM NUMBERS NECESSARY TO +C SPECIFY THE THRESHOLD ENERGY (AND ELEVEL CONTAINS THE CORRESPONDING +C ENERGIES WHEREAS JLEV CONTAINS ALL THE CHANNEL QUANTUM NUMBERS EXCEPT +C THE ORBITAL L, WHICH MAY BE A SUPERSET. THE LAST COLUMN OF THE JLEV +C ARRAY CONTAINS A POINTER TO THE ENERGY IN THE ELEVEL ARRAY. +C + MXPAR=2 + NLABV=1 + IF(LEVIN) GOTO 220 + NLEVEL=0 + NLEV=0 + DO 210 I=JMIN,JMAX,JSTEP + NLEVEL=NLEVEL+1 + JLEVEL(NLEVEL)=I +C NL IS NUMBER OF SETS OF INTERNAL QUANTUM NUMBERS FOR THIS LEVEL + NL=1+MIN(J2MAX,I) + NLEV=NLEV+NL + 210 CONTINUE + GOTO 230 + 220 WRITE(6,602) + 602 FORMAT('0 BASIS FUNCTIONS TAKEN FROM &BASIS (JLEVEL) INPUT') +C +C IF NLEV AND NLEVEL ARE DIFFERENT, IT MAY BE NECESSARY TO BUILD UP JLEV +C IN A DIFFERENT ORDER AND REARRANGE IT LATER - SEE SET3 CODING IN SETBAS + 230 NQN=3 + QNAME(1)=' J ' + QNAME(2)=' |K| ' +C LOOP OVER LEVELS AGAIN, THIS TIME SETTING UP JLEV + II=0 + IJ=0 + DO 250 I=JMIN,JMAX,JSTEP + II=II+1 + DO 250 K=0,MIN(J2MAX,I) + IJ=IJ+1 + JLEV(IJ)=I + JLEV(NLEV+IJ)=K + JLEV(NLEV*(NQN-1)+IJ)=II + 250 CONTINUE +C + IF(EIN) GOTO 280 + WRITE(6,604) ROTI(1) + 604 FORMAT('0 ENERGY LEVELS CALCULATED FROM B =',F10.5) +C + DO 270 I=1,NLEVEL + JI=JLEVEL(I) + ELEVEL(I)=ROTI(1)*DBLE(JI*(JI+1)) + 270 CONTINUE + RETURN +C + 280 WRITE(6,605) + 605 FORMAT('0 ENERGY LEVELS TAKEN FROM &BASIS (ELEVEL) INPUT') + RETURN +C + ENTRY BASE9(LCNT,N,JTOT,ICODE,JLEV,NLEV,NQN,J,L) +C +C BASE9 IS CALLED EITHER TO COUNT THE ACTUAL NUMBER OF CHANNEL BASIS +C FUNCTIONS OR ACTUALLY TO SET THEM UP (IN THE J AND L ARRAYS). +C IT IS CALLED FOR EACH TOTAL J (JTOT) AND PARITY CASE (ICODE). +C IF LCNT IS .TRUE. ON ENTRY, JUST COUNT THE BASIS FUNCTIONS. OTHERWISE, SET +C UP J (POINTER TO JLEV) AND L (ORBITAL ANGULAR MOMENTUM) FOR EACH CHANNEL. +C THIS MUST TAKE INTO ACCOUNT JTOT AND ICODE. +C ONE IMPORTANT OVERALL EFFECT IS THAT THE THRESHOLD ENERGY IS IN +C ELEVEL(JLEV(NLEV*(NQN-1)+J(I)). CHECK THIS! +C + N=0 + DO 320 I=1,NLEV + K=JLEV(NLEV+I) + IF(K.GT.JTOT) GOTO 320 + IF(K.EQ.0 .AND. ICODE.EQ.1) GOTO 320 + N=N+1 + IF(LCNT) GOTO 310 + J(N)=I + L(N)=JTOT + 310 CONTINUE + 320 CONTINUE + RETURN +C + ENTRY CPL9(N,ICODE,NPOTL,LAM,MXLAM,NLEV,JLEV,J,L,JTOT, + 1 VL,IV,CENT,IBOUND,IEXCH,IPRINT) +C +C CPL9 IS CALLED AFTER BASE9 FOR EACH JTOT AND ICODE, TO SET UP THE +C POTENTIAL COUPLING COEFFICIENTS VL. +C IF IBOUND>0, IT ALSO SETS UP THE CENTRIFUGAL COEFFICIENTS CENT. +C INDICES SPECIFYING THE MXLAM DIFFERENT POTENTIAL SYMMETRIES ARE IN +C THE FIRST XX*MXLAM ELEMENTS OF LAM; THE STRUCTURE OF THE LAM ARRAY +C (AND THE VALUE OF XX) IS CHOSEN BY THE PROGRAMMER, AND MUST +C CORRESPOND WITH THAT USED IN SUBROUTINE POTENL. +C NPOTL IS THE NUMBER OF DIFFERENT POTENTIAL TERMS WHICH CONTRIBUTE TO +C EACH MATRIX ELEMENT (SEE SUBROUTINE WAVVEC). IT SOMETIMES SAVES +C A SIGNIFICANT AMOUNT OF SPACE IF IT CAN BE LESS THAN MXLAM. +C + ROOT2=SQRT(2.D0) + NPOTL=MXLAM + DO 550 LL=1,MXLAM + LM=LAM(LL) + NNZ=0 + I=LL + DO 540 ICOL=1,N + JC=JLEV(J(ICOL)) + KC=JLEV(J(ICOL)+NLEV) + DO 540 IROW=1,ICOL + JR=JLEV(J(IROW)) + KR=JLEV(J(IROW)+NLEV) + VL(I)=0.D0 + IV(I)=LL + IF(KR.NE.KC) GOTO 510 + ISUM=LM+JR+JC + IF(ISUM-2*(ISUM/2).NE.0 .OR. LM.GT.JC+JR) GOTO 540 + VL(I)=PARITY3(KC)*SQRT(DBLE(JC*(JC+1)*JR*(JR+1)))*THREEJ(JC,LM,JR) + 1 *THRJ(DBLE(JC),DBLE(LM),DBLE(JR),DBLE(KC),0.D0,DBLE(-KC)) + IF(VL(I).NE.0.D0) NNZ=NNZ+1 + GOTO 540 + 510 IF(LM.GE.0 .OR. JR.NE.JC .OR. IABS(KR-KC).GT.1) GOTO 540 + VL(I)=SQRT(DBLE((JC*(JC+1)-KR*KC)*(JTOT*(JTOT+1)-KR*KC))) + IF(JC.EQ.0 .NEQV. JR.EQ.0) VL(I)=ROOT2*VL(I) + IF(VL(I).NE.0.D0) NNZ=NNZ+1 + 540 I=I+NPOTL + IF(NNZ.EQ.0) WRITE(6,612) JTOT,LL + 612 FORMAT(' * * * NOTE. FOR JTOT =',I4,', ALL COUPLING', + 1 ' COEFFICIENTS ARE 0.0 FOR POTENTIAL SYMMETRY',I4) + 550 CONTINUE +C +C NOW THE CENTRIFUGAL POTENTIAL + DO 570 I=1,N + JC=JLEV(J(I)) + KC=JLEV(J(I)+NLEV) + CENT(I)=DBLE(JTOT*(JTOT+1)+JC*(JC+1)-2*KC*KC) + 570 CONTINUE + RETURN +C + ENTRY DEGEN9(J1,J2,RESULT) +C +C DEGEN9 IS CALLED TO OBTAIN THE DEGENERACY FACTOR FOR THE DENOMINATOR +C OF A CROSS-SECTION CALCULATION; IT DOES NOT MATTER FOR BOUND STATES. +C +C JI=JLEVEL(J1) +C RESULT=DBLE(2*JI+1) + RETURN + END + SUBROUTINE BASE (JTOT, JLEV, N, J, L, CINT, EINT, CENT, VL, IV, + & MXLAM, NPOTL, LAM, WVEC, WGHT, IEXCH, THETA, PHI, + & ICODE, LCNT, ERED, NLEVV, PRINT) +C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . +C . CHANGED APR 1986 TO COMBINE BASIN & IOSBIN HANDLING. +C . CHANGED JAN 1988 TO ALLOW USER-DEFINED BASIS (ITYPE=9) +C . CHANGED MAR 1993 TO SET MPLMIN=TRUE FOR ITYPE=23,IDENT=1 +C . CHANGED NOV 1993 TO USE IXNEXT DIRECTLY IN PLACE OF IC. +C . IC REMOVED FROM ARGUMENT LIST OF BASIN AND SET6. +C . CHANGED JAN 1994 TO USE IV() INDEXING FOR ITYP=10*N + 2 +C . APR 1994 TO INCLUDE IEXCH IN PARAMETER LIST +C NEW ORDERING OF ITYPE=23 'PARITY CASES' +C . CHANGED JUL 1994 FOR VERSION 14 +C . AUG 1994 TO INTEGRATE ITYPE = 4 CODE TO VERSION 14 +C . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE +C BELOW IS BEGINNING OF A LIMITED SAVE LIST +C SAVE ITP,ITYPE,IOFF,IBOUND,JZCSFL,EMAXK,WTM,IGO,IGODG,MJMX +C IDENT,WT,JMAX,JMIN -- IN CMBASE +C NLEV,NQN,MPLMIN -- IN PRBASE +C +C BASE HANDLES QUANTUM BASIS SETS FOR SCATTERING CALCULATION. +C +C ITYPE DESCRIBES TARGET-PROJECTILE TYPES. +C CURRENT IMPLEMENTATION FOR +C ITYPE=1 LINEAR RIGID ROTOR HIT BY AN ATOM +C ITYPE=2 DIATOMIC VIB-ROTOR HIT BY AN ATOM +C ITYPE=3 LINEAR RIGID ROTOR - LINEAR RIGID ROTOR +C ITYPE=4 RIGID ASYMMETRIC TOP HIT BY LINEAR RIGID ROTOR +C ITYPE=5 NEAR-SYMMETRIC TOP RIGID ROTOR HIT BY AN ATOM +C ITYPE=6 ASYMMETRIC TOP RIGID ROTOR HIT BY AN ATOM. +C ITYPE=7 DIATOMIC VIB-ROTOR HIT BY AN ATOM, WHERE A FULL +C SET OF EXPECTATION VALUES OF THE INTERMOLECULAR +C POTENTIAL BETWEEN (V,J) AND (V',J') DIATOM INTERNAL +C STATES IS SUPPLIED +C ITYPE=8 ATOM-SURFACE SCATTERING +C +C ITYPE=ITYPE+10 FOR EFFECTIVE POTENTIAL METHOD OF RABITZ. +C ITYPE=ITYPE+20 FOR COUPLED STATES OF MCGUIRE-KOURI. +C ITYPE=ITYPE+30 FOR DLD METHOD OF DEPRISTO AND ALEXANDER. +C +C +C ENTRY BASIN +C READS AND PROCESSES &BASIS DATA TO DESCRIBE ASYMPTOTIC LEVELS. +C QUANTUM NOS. AND INDEXING ARE IN JLEVEL(NLEVEL) AND +C JLEV(NLEV,NQN), IN DIFFERENT FORMATS. +C ASYMPTOTIC ENERGIES ARE IN ELEVEL(NLEVEL). +C +C MAIN ENTRY BASE +C SETS UP BASIS FOR EACH PARTIAL CALCULATION FROM ASYMPTOTIC +C LEVELS (STORED IN JLEV) COUPLED WITH COLLISION ORBITAL ANGULAR +C MOMENTUM. +C LCNT=.TRUE. MEANS ONLY COUNT NUMBER OF CHANNELS +C LCNT=.FALSE. MEANS SET UP BASIS FUNCTIONS IN ALLOCATED STORAGE. +C ICODE (=1...MXPAR) IS AN INDEX FOR THE CURRENT SYMMETRY BLOCK. +C IPAR AND IEXCH SUBDIVIDE ICODE=1,MXPAR INTO +C 1) PARITY, IPAR=0 (EVEN), 1 (ODD) +C 2) EXCHANGE SYM., IEXCH=0 (NO EXCHANGE), 1 (ODD), 2 (EVEN). +C IT IS NECESSARY TO SET FOLLOWING -- +C ASYMPTOTIC LEVEL IN J, ORBITAL ANGULAR MOMENTUM IN L, +C ASYMPTOTIC ENERGY IN EINT, CENTRIFUGAL ENERGY IN CENT, +C AND COUPLING MATRIX ELEMENTS IN VL. +C +C EXTRA FEATURE ADDED AT UNIV. OF WATERLOO MAY 82. ARRAY IV +C IS AN INDEX ARRAY SUCH THAT VL(I) IS A COEFFICIENT FOR +C TERM NUMBER IV(I) IN THE POTENTIAL ARRAY RETURNED BY +C SUBROUTINE POTENL. THE INTRODUCTION OF THIS ARRAY ONLY +C MAKES ANY REAL DIFFERENCE FOR ITYPE=10*N+7, FOR WHICH IT +C ENABLES LARGE ECONOMIES IN STORAGE FOR THE VL ARRAY. +C ** 1/27/93 IV ARRAY USED IF AND ONLY IF IVLFL.GT.0 ** +C NPOTL IS THE NUMBER OF "CHUNKS" OF SIZE N*(N+1)/2 WHICH +C COMPRISE VL AND IV. NPOTL=MXLAM EXCEPT FOR ITYPE=10*N+7 AND 8. +C FOR ITYPE=10*N+7, NPOTL IS EQUAL TO K+1, WHERE K IS THE +C INDEX OF THE HIGHEST ORDER LEGENDRE POLYNOMIAL ACTUALLY +C PRESENT IN THE POTENTIAL. +C FOR ITYPE=8, NPOTL=1. +C +C ADDITIONAL CHANGE MADE MAY 82. THE VL ARRAY IS NOW STORED +C SO THAT THE POTENTIAL SYMMETRY TERM IS MOST RAPIDLY VARYING, +C RATHER THAN THE CHANNEL INDICES AS BEFORE. THIS IS TO KEEP +C PAGING TO A MINIMUM IN SUBROUTINE WAVMAT. +C +C ENTRY DEGEN PROVIDES DEGENERACY INFORMATION FOR USE IN OUTPUT. +C + DIMENSION CENT(NLEVV),EINT(NLEVV),WVEC(NLEVV),VL(NLEVV),IV(NLEVV) + LOGICAL LCNT,EIN,LEVIN,MPLMIN,LSIG + INTEGER J(NLEVV),L(NLEVV),LAM(MXLAM),JLEV(NLEVV) + INTEGER PRINT,EUNITS + CHARACTER*4 EUNITC + CHARACTER*8 QNAME(10),QTYPE(10),PRTP(4,9),PTP(2) + DIMENSION WTM(2),IOSNGP(3) +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C +C COMMON BLOCK FOR BASIS DATA +C 2 AUG 94 V14 VERSION OF CMBASE; ISYM NO LONGER EQUIV J2MAX +C DIMENSIONS OF JLEVEL,ELEVEL SET HERE AND HELD IN /CMBASE/MXJL,MXEL + PARAMETER (MXJLVL=4000,MXELVL=1000) + DIMENSION ROTI(12),ALPHAE(2),BE(2),DE(2),A(2),B(2),C(2),WE(2), + 1 WEXE(2),WT(2),ELEVEL(MXELVL),EEE(1016) + DIMENSION JLEVEL(MXJLVL),ISYM(10),ISYM2(10) + EQUIVALENCE (ROTI(1),BE(1),A(1)), (ROTI(3),ALPHAE(1),B(1)), + 1 (ROTI(5),DE(1),C(1)),(JMIN,J1MIN),(JMAX,J1MAX),(JSTEP,J1STEP), + 2 (ROTI(1),EEE(1)), (ROTI(7),WE(1),DJ ), (ROTI(8),DJK), + 3 (ROTI(9),WEXE(1),DK), (J2MAX,KSET) + COMMON /CMBASE/ ROTI,ELEVEL,EMAX,WT,SPNUC, NLEVEL,JLEVEL,JMIN, + 1 JMAX,JSTEP,ISYM,J2MIN,J2MAX,J2STEP,ISYM2,JHALF,IDENT,MXJL,MXEL +C + COMMON /PRBASE/ ITYPX,NQN,NLEV,MVALUE,IPTY,MPLMIN +C + COMMON/VLSAVE/IVLU +C +C ARRAYS FOR NAMELIST &BASIS +C CHARACTER*6 BNAMES(40) +C DIMENSION LOCN(40),INDX(40) +C +C V14: ISYM2, JHALF ADDED TO NAMELIST + NAMELIST /BASIS/ ROTI,JMIN,JMAX,JSTEP,ITYPE + 1 ,NLEVEL,JLEVEL,ELEVEL,EMAX,EMAXK,BE,ALPHAE,DE,A,B,C,WE,WEXE + 2 ,J1MAX,J1MIN,J2MAX,J2MIN,J1STEP,J2STEP + 3 ,WT,IDENT,SPNUC,EUNITS,EUNITC,IASYMU,JZCSMX,IBOUND,JZCSFL + 4 ,IOSNGP,IPHIFL,ISYM,ISYM2,KSET,IVLU,JHALF +C + DATA QTYPE/ ' J ', ' K ', + 1 ' PRTY ', ' J1 ', ' J2 ', ' J12 ', + 2 ' V ', ' TAU ',' ','SIG INDX'/ + DATA PRTP/' LINEAR',' RIGID R','OTOR - ',' ATOM. ', + 1 ' DIATOM','IC VIB-R','OTOR - ',' ATOM. ', + 2 ' LINEAR',' ROTOR -',' LINEAR ','ROTOR. ', + 3 ' ASYMME','TRIC TOP',' - LINEA','R ROTOR.', + 4 'ATOM - N','EAR SYM.',' TOP RIG','ID ROTOR', + 5 ' ASYMME','TRIC TOP',' - ATOM ',' ', + 6 4*' ', + 7 ' ATOM -',' CORRUGA','TED SURF','ACE ', + 8 4*' '/ + DATA PTP/', ODD ',', EVEN '/ +C +C +C DATA BNAMES/'ROTI','JMIN','JMAX','JSTEP','ITYPE', +C 1 'NLEVEL','JLEVEL','ELEVEL','EMAX','EMAXK', +C 2 'BE','ALPHAE','DE','A','B','C','WE','WEXE', +C 2 'J1MAX','J1MIN','J2MAX','J2MIN','J1STEP','J2STEP', +C 3 'WT','IDENT','SPNUC','EUNITS','IASYMU','JZCSMX','IBOUND', +C 4 'JZCSFL','IOSNGP','IPHIFL','ISYM','KSET','IVLU','ISYM2', +C 5 'JHALF','EUNITC'/ +C DATA INDX/40*0/ +C +C SET UP BASIS FUNCTIONS +C + IEXCH=0 + IPAR=0 +C + IF (ITYPE.EQ.8) GO TO 5208 + IF (ITP.EQ.9) GO TO 5209 + IF (ITYPE.LE.10) GO TO 5201 + IF (ITYPE.LE.20) GO TO 5202 + IF (ITYPE.LE.30) GO TO 5203 +C +C CODE FOR DECOUPLED L-DOMINANT APPROX OF ALEXANDER +C + 5204 N=0 + LAMBDA=ICODE-1 + DO 4001 I=1,NLEV + JI=JLEV(I) + LI=JTOT+LAMBDA-JI + IF (LI.LT.IABS(JTOT-JI) .OR. LI.GT.(JTOT+JI) ) GO TO 4001 + N=N+1 + IF (LCNT) GO TO 4001 + J(N)=I + L(N)=LI + 4001 CONTINUE + IF (LCNT) GO TO 5000 + GO TO 8000 +C +C CODE BELOW FOR MCGUIRE-KOURI J-Z CONSERVING COUPLED STATES APPROX. +C + 5203 N=0 +C>SG CODE BELOW IS REVISED APR 94 -- NEW ORDERING OF PARITY CASES + IF (MPLMIN) THEN + IF (IDENT.EQ.0) THEN + MVALUE=ICODE-1 + IF (ITYPE.EQ.25.AND.ISYM(1).NE.-1) THEN + IBLOCK=1+MVALUE/(MJMX+1) + MVALUE=MOD(MVALUE,MJMX+1) + KREQ=IBLOCK-1 + ENDIF + ELSE + IEXCH=2-MOD(ICODE,2) + MVALUE=(ICODE+1)/2-1 + IF (WT(IEXCH).EQ.0.D0) THEN + IF (PRINT.GE.3) WRITE(6,690) JTOT,ICODE,PTP(IEXCH) + GO TO 5000 + ENDIF + ENDIF + ELSE +C CODE BELOW IS FOR MPLMIN=.FALSE. (NOT USED, BUT COULD BE REVIVED) + IF (IDENT.EQ.0) THEN + WRITE(6,*) ' *** BASE (APR 94). MPLMIN=.FALSE. .AND. IDENT.' + 1 ,'EQ.0 ARE NOT ALLOWED' + STOP + ELSE + ICD=(ICODE+1)/2 + MVALUE=ICD/2 + IF (ICD-2*(ICD/2).EQ.0) MVALUE=-MVALUE + ENDIF + ENDIF +C SET IPAR (=1 FOR MVALUE=0, =2 OTHERWISE) + IPAR=1 + IF (MVALUE.NE.0) IPAR=2 +C VALUES NOT STORED. CALCULATE THEM + 3800 DO 1511 LL=1,MXLAM + LM=LAM(LL) + XLM=LM + NNZ=0 + I=LL + DO 1501 ICOL=1,N + JCOL=JLEV(J(ICOL) ) + XJCOL=JCOL + DO 1501 IROW=1,ICOL + JROW=JLEV(J(IROW) ) + XJROW=JROW + VL(I)=PM*SQRT(Z(JROW)*Z(JCOL))* + & THREEJ(JROW,LM,JCOL)* + & THRJ(XJROW,XLM,XJCOL,-XM,Z0,XM) + IF (VL(I).NE.0.D0) NNZ=NNZ+1 + 1501 I=I+MXLAM + IF (NNZ.LE.0 .AND. PRINT.GE.3) WRITE(6,612) MVALUE,LL + 1511 CONTINUE + RETURN + END + SUBROUTINE CPL22(N,MXLAM,NPOTL,LAM,NLEV,JLEV,J,MVALUE, + 1 IV,VL,PRINT,LFIRST) +C +C CS COUPLING MATRIX FOR VIBRATING ROTOR-ATOM (ITYPE=22) +C SG (MAR 94) USES IV(), I.E., IVLFL=1 +C SAVES COUPLING MATRIX FOR MV=0,MX IN UPPER X() ARRAY +C USES J3J000 ROUTINE AS PER JMH CPL21 CODE +C STORES ON J OR NLEV, DEPENDING ON WHICH IS SMALLER +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE NOMEM,NL12,IXMX,ISTART,IFIRST,LOGIX,JTOP +C SPECIFICATIONS FOR ARGUMENTS + DIMENSION LAM(3,MXLAM),JLEV(NLEV),J(N),VL(1),IV(1) + INTEGER PRINT + LOGICAL LFIRST +C + LOGICAL ODD,NOMEM,LOGIX + DATA Z0/0.D0/ +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C +C STATEMENT FUNCTION DEFINITIONS + Z(I)=DBLE(I+I+1) + ODD(I)=I-2*(I/2).NE.0 +C +C IF LFIRST IS TRUE (FIRST CALL), DO SOME INITIALIZATION + IF (LFIRST) THEN + IFIRST=-1 + LFIRST=.FALSE. + NOMEM=.FALSE. + ENDIF +C + XM=MVALUE + PM=1.D0 + IF (ODD(MVALUE)) PM=-1.D0 +C + IF (IFIRST.GT.-1) GO TO 3500 +C FIRST TIME THROUGH SET UP SOME STORAGE POINTERS. +C LOGIX=.TRUE. IF JTOP IS SMALLER THAN NLEV (SO STORE ON J) + JTOP=0 + DO 3400 I=1,NLEV + 3400 JTOP=MAX(JTOP,JLEV(I)) + LOGIX=JTOP.LT.NLEV + IF (LOGIX) THEN + NL12=(JTOP+1)*(JTOP+2)/2 + ELSE + NL12=NLEV*(NLEV+1)/2 + ENDIF + IXMX=NL12*NPOTL + ISTART=MX+1 +C + 3500 MVABS=IABS(MVALUE) +C SEE IF VALUES ARE STORED FOR THIS HIGH AN MVALUE +C IF NOT, TRY TO STORE THEM IN XCPL(). + IF (MVABS.LE.IFIRST.OR.NOMEM) GO TO 3900 + MV=IFIRST+1 +C FIRST CHECK THAT WE STILL HAVE A CONTINUOUS BLOCK OF HI MEMORY. + 3600 IF (MX.EQ.ISTART-(IFIRST+1)*IXMX-1) GO TO 3610 + IF (PRINT.GE.1) WRITE(6,602) MV,ISTART-1,MX,IXMX*(IFIRST+1) + 602 FORMAT(/' CPL22 (FEB 93). HIGH MEMORY FRAGMENTED. CANNOT', + 1 ' STORE COUPLING COEFFS FOR MVAL=',I3/ 19X, + 2 'ORIGINAL MINUS CURRENT MEMORY LIMITS .NE. NO. USED =',3I12) + NOMEM=.TRUE. + GO TO 3900 +C TEST FOR AVAILABLE STORAGE; NEED IXMX FOR THIS MVAL + 3610 NAVAIL=MX-IXNEXT+1 + IF (IXMX.LE.NAVAIL) GO TO 3601 + IF (PRINT.GE.3) WRITE(6,692) MV,IXMX,NAVAIL + 692 FORMAT(/' CPL22 (FEB 93). UNABLE TO STORE 3-J VALUES FOR MVAL=' + 1 ,I3/' REQUIRED AND AVAILABLE STORAGE =',2I9) +C SET NOMEM TO REFLECT INABILITY TO ADD MORE M-VALUES + NOMEM=.TRUE. + GO TO 3900 +C +C REDUCE 'TOP OF MEMORY' AND STORE COUPLING VALUES FOR THIS MVAL +C START INDEX AFTER M-BLOCKS ALREADY STORED (STARTING W/ MV=0) + 3601 MX=MX-IXMX + IX=MV*IXMX +C + PMV=1.D0 + IF (ODD(MV)) PMV=-1.D0 +C CODE BELOW FROM V12 (DEC 94) CPL21 CODE +C EXCEPT LIMIT ON IL LOOP AND VALUE OF LM + IF (LOGIX) THEN + ITOP=JTOP+1 + ELSE + ITOP=NLEV + ENDIF + DO 3200 IL=1,NPOTL + LM=IL-1 + JSAV=-1 + ITJ=IXNEXT + IXNEXT=ITJ+LM+LM+1 + NUSED=0 + CALL CHKSTR(NUSED) + DO 3201 I1=1,ITOP + IF (LOGIX) THEN + J1=I1-1 + ELSE + J1=JLEV(I1) + ENDIF + IF (J1.NE.JSAV) THEN + CALL J3J000(DBLE(J1),DBLE(LM),IVALJ,X(ITJ),XJMIN) + JMIN=IABS(J1-LM) + JMAX=J1+LM + JSAV=J1 + ENDIF + DO 3201 I2=1,I1 + IF (LOGIX) THEN + J2=I2-1 + ELSE + J2=JLEV(I2) + ENDIF + IX=IX+1 + IF (J2.LT.JMIN .OR. J2.GT.JMAX + 1 .OR. J1.LT.MV .OR. J2.LT.MV + 1 .OR. ODD(J2+JMAX)) THEN + X(ISTART-IX)=0.D0 + ELSE + INDJ=ITJ+(J2-JMIN)/2 + IF (MV.EQ.0) THEN + X(ISTART-IX)=PMV*SQRT(Z(J1)*Z(J2))*X(INDJ)**2 + ELSE + X(ISTART-IX)=PMV*SQRT(Z(J1)*Z(J2))*X(INDJ)* + 1 THRJ(DBLE(J1),DBLE(LM),DBLE(J2),-DBLE(MV),0.D0,DBLE(MV)) + ENDIF + ENDIF + 3201 CONTINUE + 3200 IXNEXT=ITJ +C + IF (PRINT.GT.3) WRITE(6,693) MV,IXMX,NAVAIL + 693 FORMAT(/' CPL22 (FEB 93). 3-J VALUES STORED FOR MVAL =',I3 + 1 /' REQUIRED AND AVAILABLE STORAGE =',2I9) +C +C RESET IFIRST TO REFLECT HIGHEST M-VALUE STORED. + IFIRST=MV +C +C SEE IF CURRENT MVALUE REQUIRES MORE STORED M-VALUES. + MV=MV+1 + IF (MV.LE.MVABS) GO TO 3600 +C +C START BY ZEROING VL, IV ARRAYS + 3900 NTOP=NPOTL*N*(N+1)/2 + DO 3999 I=1,NTOP + VL(I)=0.D0 + 3999 IV(I)=0 + IF (MVABS.GT.IFIRST) GO TO 3800 +C MVABS.LE.IFIRST. COEFFS STORED. FILL VL() FROM XCPL + IXM=MVABS*IXMX + DO 3513 LL=1,MXLAM + NNZ=0 + LM=LAM(1,LL) + NV=LAM(2,LL) + NV1=LAM(3,LL) +C ICR COUNTS ICOL,IROW LOOP; NEEDED FOR IXVL (VL INDEX) + ICR=0 + DO 3503 ICOL=1,N + I1=J(ICOL) + J1=JLEV(I1) + NVC=JLEV(NLEV+I1) + DO 3503 IROW=1,ICOL + I2=J(IROW) + J2=JLEV(I2) + NVR=JLEV(NLEV+I2) + ICR=ICR+1 + IF((NV.EQ.NVC.AND.NV1.EQ.NVR) .OR. (NV.EQ.NVR.AND.NV1.EQ.NVC)) + 1 THEN +C FIRST GET INDEX IN VL, IV + IXVL=(ICR-1)*NPOTL+LM+1 +C THEN GET INDEX OF STORED COUPLING COEFFICIENT, DEPENDING ON LOGIX + IF (LOGIX) THEN + IF (J1.GT.J2) THEN + IX12=(J1+1)*J1/2+J2+1 + ELSE + IX12=(J2+1)*J2/2+J1+1 + ENDIF + ELSE + IF (I1.GT.I2) THEN + IX12=I1*(I1-1)/2+I2 + ELSE + IX12=I2*(I2-1)/2+I1 + ENDIF + ENDIF + IX=IXM+LM*NL12+IX12 + IV(IXVL)=LL + VL(IXVL)=X(ISTART-IX) + IF (VL(IXVL).NE.0.D0) NNZ=NNZ+1 +C WE HAVE STORED COUPLING FOR POSITIVE MVALUES; CORRECT IF NEC + IF (MVALUE.LT.0.AND.ODD(J1+J2+LM)) VL(IXVL)=-VL(IXVL) + ENDIF + 3503 CONTINUE + IF (NNZ.LE.0 .AND. PRINT.GT.3) WRITE(6,612) MVALUE,LL + 612 FORMAT(' * * * NOTE. FOR MVALUE, SYM =',2I4,', ALL COUPLING ', + & 'COEFFICIENTS ARE 0.') + 3513 CONTINUE + RETURN +C +C MV.GT.IFIRST ==> VALUES NOT STORED. CALCULATE THEM + 3800 DO 1511 LL=1,MXLAM + LM=LAM(1,LL) + NV=LAM(2,LL) + NV1=LAM(3,LL) + XLM=LM + NNZ=0 +C ICR COUNTS ICOL,IROW LOOP; NEEDED FOR IXVL (VL INDEX) + ICR=0 + DO 1501 ICOL=1,N + JCOL=JLEV(J(ICOL) ) + XJCOL=JCOL + NVC=JLEV(NLEV+J(ICOL)) + DO 1501 IROW=1,ICOL + JROW=JLEV(J(IROW) ) + XJROW=JROW + NVR=JLEV(NLEV+J(IROW)) + ICR=ICR+1 + IF((NV.EQ.NVC.AND.NV1.EQ.NVR) .OR. (NV.EQ.NVR.AND.NV1.EQ.NVC)) + 1 THEN + IXVL=(ICR-1)*NPOTL+LM+1 + IV(IXVL)=LL + VL(IXVL)=PM*SQRT(Z(JROW)*Z(JCOL))* + & THREEJ(JROW,LM,JCOL)* + & THRJ(XJROW,XLM,XJCOL,-XM,Z0,XM) + IF (VL(IXVL).NE.0.D0) NNZ=NNZ+1 + ENDIF + 1501 CONTINUE + IF (NNZ.LE.0 .AND. PRINT.GT.3) WRITE(6,612) MVALUE,LL + 1511 CONTINUE + RETURN + END + SUBROUTINE CPL23(N,MXLAM,LAM,NLEV,JLEV,J,L,MVALUE,IEX,VL,PRINT, + 1 LFIRST) +C CS COUPLING MATRIX FOR LINEAR ROTOR-LINEAR ROTOR (ITYPE=23) +C SAVES M-INDEPENDENT PARTS USING NEW DYNAMIC STORAGE +C AND IVLFL IN VERSION '12X' OF MOLSCAT. +C VERSION 5. LINEAR XCPL NOW STORED BACKWARDS IN HI LOCS OF X(). +C JAN 93 IVLFL CHECKED BEFORE CALL CPL23 AND IV NO LONGER USED +C M-INDEPENDENT PARTS (9-J) STORED IROW.GE.ICOL. +C M-DEPENDENT (3J) PARTS STORED IF MEMORY ALLOWS. +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE NOMEM,NL12,J12MX,NJ12,NXPM,NLM,IHL,IXEX,IXTJ,IXMX,ISTART + 1 ,IFIRST +C + INTEGER PRINT + INTEGER LAM(2),JLEV(NLEV,3),J(2),L(2) + LOGICAL ODD,NOMEM,LFIRST + DIMENSION VL(2) +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C + DATA SQRTHF/.70710678118654753D0/, Z0/0.D0/ + DATA PIFCT/2.24483902656458321D-2/ + Z(I)=DBLE(I+I+1) + ODD(I)=I-2*(I/2).NE.0 +C +C INITIALIZE IFIRST IF LFIRST IS SET TO TRUE + IF (LFIRST) THEN + IFIRST=-2 + LFIRST=.FALSE. + NOMEM=.FALSE. + ENDIF + XM=MVALUE +C + PM=PARITY3(MVALUE) + IF (IFIRST.GT.-2) GO TO 3500 +C FIRST TIME THROUGH EVALUATE MVALUE-INDEPENDENT PARTS OF VL() +C SET-UP AND CHECK STORAGE ... + NL12=NLEV*(NLEV+1)/2 + IXMX=NL12*MXLAM + IXEX=IXMX + IF (IEX.GT.0) IXMX=2*IXMX + NAVAIL=MX-IXNEXT+1 + IF (IXMX.LE.NAVAIL) GO TO 3010 + WRITE(6,601) NLEV,MXLAM,IEX,IXMX,NAVAIL + 601 FORMAT(/' ***** MCGCPL (JAN 93) NLEV,MXLAM,IEX =',3I4 + 1 /' REQUIRED STORAGE MORE THAN AVAILABLE',2I9) + STOP +C +C SET ISTART SO THAT X(ISTART-IX) IS XCPL(IX), REDUCE MX, +C AND SET-UP THE NINEJ PARTS IN X(). + 3010 ISTART=MX+1 + MX=MX-IXMX + DO 3100 LL=1,MXLAM + LM1=LAM(3*LL-2) + LM2=LAM(3*LL-1) + LM=LAM(3*LL) + IL12=0 + DO 3100 I1=1,NLEV + J1=JLEV(I1,1) + J2=JLEV(I1,2) + J12=JLEV(I1,3) + DO 3100 I2=1,I1 + IL12=IL12+1 + J1P=JLEV(I2,1) + J2P=JLEV(I2,2) + J12P=JLEV(I2,3) + FACTOR=PIFCT*Z(LM)*SQRT(Z(J12)*Z(J12P)*Z(J1)*Z(J1P)*Z(J2)*Z(J2P) + 1 *Z(LM1)*Z(LM2))*PARITY3(J1+J2+J12) +C XCPL(IL12,LL,1) + IX=(LL-1)*NL12+IL12 + X(ISTART-IX)=THREEJ(J1,LM1,J1P)*THREEJ(J2,LM2,J2P)* + 1 XNINEJ(J12P,J2P,J1P,J12,J2,J1,LM,LM2,LM1)*FACTOR + IF (IEX.EQ.0) GO TO 3100 + IF (J1.EQ.J2) THEN + X(ISTART-IXEX-IX)=X(ISTART-IX) + ELSE + X(ISTART-IXEX-IX)=THREEJ(J2,LM1,J1P)*THREEJ(J1,LM2,J2P)* + 1 XNINEJ(J12P,J2P,J1P,J12,J1,J2,LM,LM2,LM1)*FACTOR + ENDIF + 3100 CONTINUE + IF (PRINT.GT.3) WRITE(6,691) IXMX,NAVAIL + 691 FORMAT(/' CPL23 (JAN 93). 9-J PARTS STORED. USED, AVAILABLE=' + 1 ,2I9) +C RESET IFIRST TO INDICATE THAT NINE-J PARTS ARE STORED + IFIRST=-1 +C NOW CALCULATE PARMS NEEDED TO STORE M-DEPENDENT (THRJ) PARTS. + IXTJ=IXMX + J12MX=0 + DO 3002 I=1,NLEV + 3002 J12MX=MAX(J12MX,JLEV(I,3)) + NJ12=(J12MX+1)*(J12MX+2)/2 + LMAX=0 + IHL=2 + DO 3003 I=1,MXLAM + IF (ODD(LAM(3*I))) IHL=1 + 3003 LMAX=MAX(LMAX,LAM(3*I)) + NLM=LMAX/IHL+1 + NXPM=NJ12*NLM +C +C SEE IF REQUIRED M-DEPENDENT VALUES (THRJ) ARE STORED. +C IF NOT, TRY TO STORE THEM IN XCPL(). + 3500 MVABS=IABS(MVALUE) + IF (MVABS.LE.IFIRST.OR.NOMEM) GO TO 3900 + MV=IFIRST+1 +C FIRST CHECK THAT WE STILL HAVE A CONTINUOUS BLOCK OF HI MEMORY. + 3600 IF (MX.EQ.ISTART-IXMX-1) GO TO 3610 + IF (PRINT.GE.1) WRITE(6,602) MV,ISTART-1,MX,IXMX + 602 FORMAT(/' CPL23 (JAN 93). HIGH MEMORY FRAGMENTED. CANNOT', + 1 ' STORE 3-J VALUES FOR MVAL=',I3/ 19X, + 2 'ORIGINAL MINUS CURRENT MEMORY LIMITS .NE. NO. USED =',3I12) + NOMEM=.TRUE. + GO TO 3900 +C TEST FOR AVAILABLE STORAGE; NEED NXPM FOR THIS MVAL + 3610 NAVAIL=MX-IXNEXT+1 + IF (NXPM.LE.NAVAIL) GO TO 3601 + IF (PRINT.GE.3) WRITE(6,692) MVABS,NXPM,NAVAIL + 692 FORMAT(/' CPL23 (JAN 93). UNABLE TO STORE 3-J VALUES FOR MVAL=' + 1 ,I3/' REQUIRED AND AVAILABLE STORAGE =',2I9) +C SET NOMEM TO REFLECT INABILITY TO ADD MORE M-VALUES + NOMEM=.TRUE. + GO TO 3900 +C UPDATE MEMORY POINTERS AND STORE 3-J VALUES FOR THIS MVAL + 3601 IXMX=IXMX+NXPM + MX=MX-NXPM + XMV=MV + LL=0 + DO 3200 IL=1,NLM + XLM=LL + IXJ12=0 + DO 3201 J12=0,J12MX + XJ12=J12 + DO 3201 J12P=0,J12 + XJ12P=J12P +C IXJ12=J12*(J12+1)/2+J12P+1 + IXJ12=IXJ12+1 +C IX=IXTJ+MV*NXPM+(IL-1)*NJ12+IXJ12 <==> (IXJ12,IL,MV+1) + IX=MV*NXPM+(IL-1)*NJ12+IXJ12 + 3201 X(ISTART-IXTJ-IX)=THRJ(XJ12,XLM,XJ12P,XMV,Z0,-XMV) + 3200 LL=LL+IHL + IF (PRINT.GT.3) WRITE(6,693) MV,NXPM,NAVAIL + 693 FORMAT(/' CPL23 (JAN 93). 3-J VALUES STORED FOR MVAL =',I3 + 1 /' REQUIRED AND AVAILABLE STORAGE =',2I9) +C RESET IFIRST TO REFLECT HIGHEST M-VALUE STORED. + IFIRST=MV +C SEE IF CURRENT MVALUE REQUIRES MORE STORED M-VALUES. + MV=MV+1 + IF (MV.LE.MVABS) GO TO 3600 +C +C FILL VL() FROM XCPL + 3900 DO 3513 LL=1,MXLAM + NNZ=0 + I=LL + LM=LAM(3*LL) + XLM=LM + IL=LM/IHL+1 + DO 3503 ICOL=1,N + I1=J(ICOL) + J1=JLEV(I1, 1) + J2=JLEV(I1, 2) + J12=JLEV(I1 ,3) + XJ12=J12 + DO 3503 IROW=1,ICOL + I2=J(IROW) + J1P=JLEV(I2,1) + J2P=JLEV(I2,2) + J12P=JLEV(I2 ,3) + XJ12P=J12P +C FIRST GET THRJ(J12,LM,J12P,M,0,-M) -- EITHER CALC OR FROM STORAG + IF (MVABS.GT.IFIRST) THEN + TJM=THRJ(XJ12,XLM,XJ12P,XM,Z0,-XM)*PM + ELSE +C NB WE HAVE STORED ON J.GE.J'; (J,L,J'/M,0,-M)=(J',L,J/M,0,-M) +C ALSO, (J,L,J'/-M,0,M)=PARITY3(J+L+J')*(J,L,J'/M,0,-M) + IF (J12.GE.J12P) THEN + IXJ12=J12*(J12+1)/2+J12P+1 + ELSE + IXJ12=J12P*(J12P+1)/2+J12+1 + ENDIF + IXM=MVABS*NXPM+(IL-1)*NJ12+IXJ12 + TJM=X(ISTART-IXTJ-IXM)*PM + IF (MVALUE.LT.0.AND.ODD(J12+J12P+LM)) TJM=-TJM + ENDIF +C THEN GET NINEJ() PARTS + IF (I1.GE.I2) THEN + IL12=I1*(I1-1)/2+I2 + ELSE + IL12=I2*(I2-1)/2+I1 + ENDIF + IX=(LL-1)*NL12+IL12 + VL(I)=X(ISTART-IX)*TJM + IF (IEX.EQ.0) GO TO 3593 +C *** CODE BELOW ASSUMES THAT SYMMETRICALLY RELATED TERMS ARE BOTH +C *** PRESENT IN POTENTIAL. +C ((((((((((((((( EXCHANGE SHOULD BE CHECKED ))))))))))))))))))) + IF (J1.NE.J2) GO TO 3594 + T=VL(I) + GO TO 3595 + 3594 T=X(ISTART-IXEX-IX)*TJM + 3595 VL(I)=VL(I)+PARITY3(IEX+J1+J2-J12+L(ICOL))*T + IF (J1.EQ.J2) VL(I)=VL(I)*SQRTHF + IF (J1P.EQ.J2P)VL(I)=VL(I)*SQRTHF + 3593 IF (VL(I).NE.0.D0) NNZ=NNZ+1 + 3503 I=I+MXLAM + IF (NNZ.LE.0 .AND. PRINT.GE.3) WRITE(6,612) MVALUE,LL + 612 FORMAT(' * * * NOTE. FOR MVALUE, LAM =',2I4,', ALL COUPLING ', + & 'COEFFICIENTS ARE 0.') + 3513 CONTINUE + RETURN +C + END + SUBROUTINE CPL25(N,MXLAM,LAM,NLEV,JLEV,J,MVALUE,VL,PRINT,LFIRST) +C +C CS COUPLING MATRIX FOR SYMMETRIC TOP ROTOR-ATOM (ITYPE=25) +C SAVES COUPLING COEFFICIENTS USING NEW DYNAMIC STORAGE +C N.B. IV() IS NO LONGER USED; CONTROLLED BY IVLFL IN /MEMORY/ +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE NOMEM,NL12,IXMX,ISTART,IFIRST +C +C SPECIFICATIONS FOR ARGUMENTS + DIMENSION LAM(MXLAM),JLEV(NLEV,3),J(N),VL(1) + INTEGER PRINT + LOGICAL LFIRST +C + LOGICAL ODD,NOMEM +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C + DATA Z0/0.D0/, HALF/0.5D0/, ONE/1.D0/ +C +C STATEMENT FUNCTION DEFINITIONS + ODD(I)=I-2*(I/2).NE.0 +C +C IF LFIRST IS TRUE (FIRST CALL), DO SOME INITIALIZATION + IF (LFIRST) THEN + IFIRST=-1 + LFIRST=.FALSE. + NOMEM=.FALSE. + ENDIF +C + SQRTHF=SQRT(HALF) + XM=MVALUE +C + IF (IFIRST.GT.-1) GO TO 3500 +C FIRST TIME THROUGH SET UP SOME STORAGE POINTERS + NL12=NLEV*(NLEV+1)/2 + IXMX=NL12*MXLAM + ISTART=MX+1 +C + 3500 MVABS=IABS(MVALUE) +C SEE IF VALUES ARE STORED FOR THIS HIGH AN MVALUE +C IF NOT, TRY TO STORE THEM IN XCPL(). + IF (MVABS.LE.IFIRST.OR.NOMEM) GO TO 3900 + MV=IFIRST+1 +C FIRST CHECK THAT WE STILL HAVE A CONTINUOUS BLOCK OF HI MEMORY. + 3600 IF (MX.EQ.ISTART-(IFIRST+1)*IXMX-1) GO TO 3610 + IF (PRINT.GE.1) WRITE(6,602) MV,ISTART-1,MX,IXMX*(IFIRST+1) + 602 FORMAT(/' CPL25 (FEB 93). HIGH MEMORY FRAGMENTED. CANNOT', + 1 ' STORE COUPLING COEFFS FOR MVAL=',I3/19X, + 2 'ORIGINAL MINUS CURRENT MEMORY LIMITS .NE. NO. USED =',3I12) + NOMEM=.TRUE. + GO TO 3900 +C TEST FOR AVAILABLE STORAGE; NEED IXMX FOR THIS MVAL + 3610 NAVAIL=MX-IXNEXT+1 + IF (IXMX.LE.NAVAIL) GO TO 3601 + IF (PRINT.GE.3) WRITE(6,692) MV,IXMX,NAVAIL + 692 FORMAT(/' CPL25 (FEB 93). UNABLE TO STORE 3-J VALUES FOR MVAL=' + 1 ,I3/' REQUIRED AND AVAILABLE STORAGE =',2I9) +C SET NOMEM TO REFLECT INABILITY TO ADD MORE M-VALUES + NOMEM=.TRUE. + GO TO 3900 +C +C REDUCE 'TOP OF MEMORY' AND STORE COUPLING VALUES FOR THIS MVAL + 3601 MX=MX-IXMX +C START INDEX AFTER M-BLOCKS ALREADY STORED (STARTING WITH MV=0) + IX=MV*IXMX + DO 3200 IL=1,MXLAM + LM=LAM(2*IL-1) + MU=LAM(2*IL) + DO 3201 I1=1,NLEV + J1=JLEV(I1,1) + K1=JLEV(I1,2) + IS1=JLEV(I1,3) + DO 3201 I2=1,I1 + J2=JLEV(I2,1) + K2=JLEV(I2,2) + IS2=JLEV(I2,3) + IX=IX+1 + XCPL=Z0 + IF (J1.LT.MV.OR.J2.LT.MV) GO TO 3201 + PARFCT=(ONE+PARITY3(J1+J2+IS1+IS2+LM+MU))*HALF + IF (PARFCT.LE.1.D-5) GO TO 3201 + IF (K1.EQ.0) PARFCT=PARFCT*SQRTHF + IF (K2.EQ.0) PARFCT=PARFCT*SQRTHF + KDIF=K2-K1 + IF (IABS(KDIF).NE.MU) GO TO 3205 + WPAR=ONE + IF (KDIF.LT.0.AND.ODD(MU)) WPAR=-WPAR +C CONTRIBUTION FROM (J1, K1, MVALUE / Y(LM,MU) / J2, K2, MVALUE) + XCPL=PARFCT*WPAR*GSYMTP(J1,K1,J2,K2,MVALUE,LM,KDIF) + 3205 KSUM=K2+K1 + IF (IABS(KSUM).NE.MU) GO TO 3201 +C CONTRIBUTION FROM (J1,-K1,MVALUE / Y(LM,MU) / J2,K2,MVALUE) + XCPL=XCPL+PARFCT*PARITY3(IS1)* + & GSYMTP(J1,-K1,J2,K2,MVALUE,LM,KSUM) + 3201 X(ISTART-IX)=XCPL + 3200 CONTINUE + IF (PRINT.GT.3) WRITE(6,693) MV,IXMX,NAVAIL + 693 FORMAT(/' CPL25 (FEB 93). 3-J VALUES STORED FOR MVAL =',I3 + 1 /' REQUIRED AND AVAILABLE STORAGE =',2I9) +C RESET IFIRST TO REFLECT HIGHEST M-VALUE STORED. + IFIRST=MV +C SEE IF CURRENT MVALUE REQUIRES MORE STORED M-VALUES. + MV=MV+1 + IF (MV.LE.MVABS) GO TO 3600 +C + 3900 IF (MVABS.GT.IFIRST) GO TO 3800 +C MVABS.LE.IFIRST. COEFFS STORED. FILL VL() FROM XCPL + IXM=MVABS*IXMX + DO 3513 LL=1,MXLAM + NNZ=0 + I=LL + LM=LAM(LL) + DO 3503 ICOL=1,N + I1=J(ICOL) + J1=JLEV(I1,1) + DO 3503 IROW=1,ICOL + I2=J(IROW) + J2=JLEV(I2,1) + IF (I1.GT.I2) THEN + IX12=I1*(I1-1)/2+I2 + ELSE + IX12=I2*(I2-1)/2+I1 + ENDIF + IX=IXM+(LL-1)*NL12+IX12 + VL(I)=X(ISTART-IX) +C WE HAVE STORED COUPLING FOR POSITIVE MVALUES; CORRECT IF NECESSARY +C FOR PARITY OF THRJ(J1,LM,J2,-MVAL,0,MVAL) + IF (MVALUE.LT.0.AND.ODD(J1+J2+LM)) VL(I)=-VL(I) + 3593 IF (VL(I).NE.Z0) NNZ=NNZ+1 + 3503 I=I+MXLAM + IF (NNZ.LE.0 .AND. PRINT.GE.3) WRITE(6,612) MVALUE,LL + 612 FORMAT(' * * * NOTE. FOR MVALUE, SYM =',2I4,', ALL COUPLING ', + & 'COEFFICIENTS ARE 0.') + 3513 CONTINUE + RETURN +C +C MV.GT.IFIRST ==> VALUES NOT STORED. CALCULATE THEM + 3800 DO 5555 LL=1,MXLAM + NNZ=0 + I=LL + LM=LAM(2*LL-1) + MU=LAM(2*LL) + DO 5565 ICOL=1,N + J1=JLEV(J(ICOL),1) + K1=JLEV(J(ICOL),2) + IS1=JLEV(J(ICOL),3) + DO 5565 IROW=1,ICOL + J2=JLEV(J(IROW),1) + K2=JLEV(J(IROW),2) + IS2=JLEV(J(IROW),3) + VL(I)=Z0 + PARFCT=(ONE+PARITY3(J1+J2+IS1+IS2+LM+MU))*HALF + IF (PARFCT.LE.1.D-5) GO TO 5565 + IF (K1.EQ.0) PARFCT=PARFCT*SQRTHF + IF (K2.EQ.0) PARFCT=PARFCT*SQRTHF + KDIF=K2-K1 + IF (IABS(KDIF).NE.MU) GO TO 5575 + WPAR=ONE + IF (KDIF.LT.0.AND.ODD(MU)) WPAR=-WPAR +C CONTRIBUTION FROM (J1, K1, MVALUE / Y(LM,MU) / J2, K2, MVALUE) + VL(I)=VL(I) + PARFCT*WPAR*GSYMTP(J1,K1,J2,K2,MVALUE,LM,KDIF) + 5575 KSUM=K2+K1 + IF (IABS(KSUM).NE.MU) GO TO 5585 +C CONTRIBUTION FROM (J1,-K1,MVALUE / Y(LM,MU) / J2,K2,MVALUE) + VL(I)=VL(I)+PARFCT*PARITY3(IS1)* + & GSYMTP(J1,-K1,J2,K2,MVALUE,LM,KSUM) + 5585 IF (ABS(VL(I)).GE.1.D-5) NNZ=NNZ+1 + 5565 I=I+MXLAM + IF (NNZ.EQ.0) WRITE(6,612) MVALUE,LL + 5555 CONTINUE + RETURN + END + SUBROUTINE CPL3(N,MXLAM,LAM,NLEV,JLEV,J,L,JTOT,VL,IEX,PRINT, + 1 LFIRST) +C COUPLING MATRIX ELEMENTS FOR LINEAR ROTOR-LINEAR ROTOR (ITYPE=3) +C JAN 93 CODE TO SAVE JTOT-INDEPENDENT PARTS IN DEDICATED STORAGE +C WORKS W/ NEW DYNAMIC STORAGE CAPABILITIES. IVLFL CHECKED +C BEFORE CALL CPL3 AND IV NO LONGER USED. +C +C LOWER DIAGONAL OF XCPL IS STORED FOR MAIN COUPLING ELEMENTS +C BUT EXCHANGE PART REQUIRES FULL MATRIX (NLEV,NLEV) STORAGE. +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE IXEX,ISTART,IFIRST + LOGICAL ODD,LFIRST + INTEGER PRINT + DIMENSION LAM(1),JLEV(NLEV,3),J(1),L(1) + DIMENSION VL(1) +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C +C CONST IS FACTOR (4.*PI)**(-3/2) + DATA CONST/2.24483902656458321D-2/, SQRTHF/.70710678118654753D0/ +C STATEMENT FUNCTIONS + ODD(I)=I-2*(I/2).NE.0 + Z(I)=DBLE(I+I+1) +C +C INITIALIZE IFIRST IF LFIRST IS SET TRUE + IF (LFIRST) THEN + IFIRST=0 + LFIRST=.FALSE. + ENDIF +C + NLSQ=NLEV*NLEV + NL12=NLEV*(NLEV+1)/2 + IF (IFIRST.GT.0) GO TO 8030 +C +C FIRST TIME THROUGH EVALUATE JTOT-INDEPENDENT PARTS OF VL() + IXMX=NL12*MXLAM + IXEX=IXMX + IF (IEX.GT.0) IXMX=IXEX+NLSQ*MXLAM + NAVAIL=MX-IXNEXT+1 + IF (IXMX.LE.NAVAIL) GO TO 3010 + WRITE(6,699) NLEV,MXLAM,IEX,IXMX,NAVAIL + 699 FORMAT(/' ***** CPL3 (JAN 93) NLEV,MXLAM,IEX =',3I4 + 1 /' REQUIRED STORAGE MORE THAN AVAILABLE',2I9) + STOP +C UPDATE STORAGE POINTERS. NB WE STORE XPCL BACKWARDS AT TOP OF X() + 3010 ISTART=MX+1 + MX=MX-IXMX + DO 3100 LL=1,MXLAM + LM1=LAM(3*LL-2) + LM2=LAM(3*LL-1) + LM=LAM(3*LL) + IL12=0 + DO 3100 I1=1,NLEV + J1=JLEV(I1,1) + J2=JLEV(I1,2) + J12=JLEV(I1,3) + DO 3100 I2=1,I1 + IL12=IL12+1 + J1P=JLEV(I2,1) + J2P=JLEV(I2,2) + J12P=JLEV(I2,3) +C INDEX FOR XCPL(IL12,LL,1), I.E., SYMMETRIZED + IX=(LL-1)*NL12+IL12 + FACTOR=CONST*Z(LM)*SQRT((Z(LM1)*Z(LM2))*(Z(J1)*Z(J2)*Z(J12))* + 1 (Z(J1P)*Z(J2P)*Z(J12P))) + JSUM=J1+J2+J12P + IF (ODD(JSUM)) FACTOR=-FACTOR + X(ISTART-IX)=THREEJ(LM1,J1P,J1)*THREEJ(LM2,J2P,J2)* + 1 XNINEJ(J12P,J2P,J1P,J12,J2,J1,LM,LM2,LM1)*FACTOR + IF (IEX.EQ.0) GO TO 3100 +C INDEX FOR XCPL(I2,I1,LL,2), I.E., UNSYMMETRIZED + IE=(LL-1)*NLSQ+(I1-1)*NLEV+I2 + IF (J1.EQ.J2) THEN + X(ISTART-IXEX-IE)=X(ISTART-IX) + ELSE + X(ISTART-IXEX-IE)=THREEJ(LM1,J1P,J2)*THREEJ(LM2,J2P,J1)* + 1 XNINEJ(J12P,J2P,J1P,J12,J1,J2,LM,LM2,LM1)*FACTOR + ENDIF + IF (I1.EQ.I2) GO TO 3100 +C ELSE WE NEED TO STORE I1<->I2 VALUES + IE=(LL-1)*NLSQ+(I2-1)*NLEV+I1 + IF (J1P.EQ.J2P) THEN + X(ISTART-IXEX-IE)=X(ISTART-IX) + ELSE + X(ISTART-IXEX-IE)=THREEJ(LM1,J2P,J1)*THREEJ(LM2,J1P,J2)* + 1 XNINEJ(J12P,J1P,J2P,J12,J2,J1,LM,LM2,LM1)*FACTOR + ENDIF + 3100 CONTINUE + IF (PRINT.GT.3) WRITE(6,697) NLEV,MXLAM,IEX,IXMX,NAVAIL + 697 FORMAT(/' CPL3 (JAN 93). ', + 1 ' JTOT-INDEPENDENT PARTS OF COUPLING MATRIX STORED', + 2 '. NLEV, MXLAM, IEX =',3I4/ + 3 19X,'REQUIRED AND AVAILABLE STORAGE =',2I9) +C RESET IFIRST + IFIRST=1 +C +C EVALUATE VL() USING STORED JTOT-INDEPENDENT PARTS + 8030 DO 1513 LL=1,MXLAM + NNZ=0 + I=LL + LM=LAM(3*LL) + DO 1503 ICOL=1,N + LV=L(ICOL) + I1=J(ICOL) + J1=JLEV(I1,1) + J2=JLEV(I1,2) + J12=JLEV(I1,3) + DO 1503 IROW=1,ICOL + LVP=L(IROW) + I2=J(IROW) + J1P=JLEV(I2,1) + J2P=JLEV(I2,2) + J12P=JLEV(I2,3) +C GET JTOT-DEPENDENT PARTS + XFACT=SQRT(Z(LV)*Z(LVP))*THREEJ(LM,LVP,LV) + 1 *SIXJ(LVP,LV,J12P,J12,LM,JTOT) + IF (ODD(JTOT)) XFACT=-XFACT +C GET JTOT-INDEPENDENT PARTS FROM XCPL. +C BELOW IS FOR SYMMETRIZED MAIN PART + IF (I1.GE.I2) THEN + IL12=I1*(I1-1)/2+I2 + ELSE + IL12=I2*(I2-1)/2+I1 + ENDIF + IX=(LL-1)*NL12+IL12 + VL(I)=XFACT*X(ISTART-IX) + IF (IEX.EQ.0) GO TO 1593 +C *** +C *** N.B. CODE BELOW ASSUMES THAT SYMMETRICALLY RELATED POTENTIAL TERMS +C *** I.E. A(LM1,LM2,LM) AND A(LM2,LM1,LM) ARE BOTH PRESENT IN POTL. +C *** +C BELOW IS FOR XCPL(I2,I1,LL,IEX) STORAGE ORDER + IE=(LL-1)*NLSQ+(I1-1)*NLEV+I2 + IF (J1.NE.J2) GO TO 1594 + T=VL(I) + GO TO 1595 + 1594 T=XFACT*X(ISTART-IXEX-IE) + 1595 JSUM=IEX+J1+J2-J12+LV + IF (ODD(JSUM)) T=-T + VL(I)=VL(I)+T + IF (J1.EQ.J2) VL(I)=VL(I)*SQRTHF + IF (J1P.EQ.J2P) VL(I)=VL(I)*SQRTHF + 1593 IF (VL(I).NE.0.D0) NNZ=NNZ+1 + 1503 I=I+MXLAM + IF (NNZ.LE.0.AND.PRINT.GE.4) WRITE(6,612) JTOT, LL + 612 FORMAT(' * * * NOTE. FOR JTOT =',I4,', ALL COUPLING ', + 1 'COEFFICIENTS ARE 0.0 FOR SYMMETRY',I4) + 1513 CONTINUE + RETURN + END + SUBROUTINE CPL4(N,J,L,JTOT,MXLAM,LAM,VL,JLEV,ATAU,NLEV, + 1 PRINT,LFIRST) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE IFIRST,NOMEM,NL12,IXMX,ISTART +C COUPLING MATRIX ELEMENTS FOR ITYPE=4 (CPL4) & ITYPE=24 (CPL24) +C SPECIFICATIONS FOR PARAMETER LIST + INTEGER J(N),L(N),LAM(2),JLEV(2) + INTEGER PRINT + DIMENSION ATAU(2),VL(2) + LOGICAL LFIRST +C + INTEGER P1,Q1,P2,P + LOGICAL ODD,NOMEM +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C + COMMON /VLSAVE/ IVLU +C + DATA PI/3.141592653589793D0/ + DATA EPS/1.D-8/, Z0/0.D0/ +C +C STATEMENT FUNCTIONS ... + F(NN) = DBLE(NN+NN+1) + ODD(I) = I-2*(I/2).NE.0 +C + IF (LFIRST) THEN + IFIRST=-1 + LFIRST=.FALSE. + NOMEM=.FALSE. + ENDIF + IF (IFIRST.GT.-1) GO TO 5500 + IF (NOMEM) GO TO 5900 + NL12=NLEV*(NLEV+1)/2 + IXMX=NL12*MXLAM + ISTART=MX+1 + NAVAIL=ISTART-IXNEXT + IF (IXMX.LE.NAVAIL) GO TO 5100 + IF (PRINT.GE.3) WRITE(6,694) IXMX,NAVAIL + 694 FORMAT(/' CPL4 (JUL 93). UNABLE TO STORE JTOT-INDEPENDENT PART' + 1 /' REQUIRED AND AVAILABLE STORAGE =',2I9) + NOMEM=.TRUE. + GO TO 5900 + 5100 IX=0 + DO 5200 LL=1,MXLAM + P1 = LAM(4*LL-3) + Q1 = LAM(4*LL-2) + P2 = LAM(4*LL-1) + P = LAM(4*LL) + XP1 = P1 + XQ1 = Q1 + DO 5201 IC=1,NLEV + JC=JLEV(IC) + J1C = JLEV(IC + 2*NLEV) + J2C = JLEV(IC + NLEV) + XJC = JC + XJ1C = J1C + XJ2C = J2C + ISTC = JLEV(IC + 5*NLEV) + NKC = JLEV(IC + 6*NLEV) + DO 5201 IR=1,IC + IX=IX+1 + JR=JLEV(IR) + J1R = JLEV(IR + 2*NLEV) + J2R = JLEV(IR + NLEV) + XJR=JR + XJ1R = J1R + XJ2R = J2R + ISTR=JLEV(IR+5*NLEV) + NKR=JLEV(IR+6*NLEV) + XCPL=Z0 + KKC=-J1C + DO 5300 KC=1,NKC +C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. + IF (ABS(ATAU(ISTC+KC)).LE.EPS) GO TO 5300 + XKC=KKC + KKR=-J1R + DO 5400 KR=1,NKR +C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. + IF (ABS(ATAU(ISTR+KR)).LE.EPS) GO TO 5400 + XKR=KKR +C AF=ATAU(ISTR+KR)*ATAU(ISTC+KC)*PARITY3(KKR) + AF=ATAU(ISTR+KR)*ATAU(ISTC+KC) + IF (ODD(KKR)) AF=-AF + IF (KKR-KKC.NE.Q1) GO TO 5401 + XCPL=XCPL+AF*THRJ(XJ1R,XP1,XJ1C,-XKR,XQ1,XKC) + IF (Q1.EQ.0) GO TO 5400 + 5401 IF (KKC-KKR.NE.Q1) GO TO 5400 +C ADJUST FOR (-1)**MU IN POTENTIAL. . . + AF=AF*PARITY3(P1+Q1+P2+P) + XCPL=XCPL+AF*THRJ(XJ1R,XP1,XJ1C,-XKR,-XQ1,XKC) + 5400 KKR=KKR+1 + 5300 KKC=KKC+1 +C NOW GET 'CONSTANT FACTORS' + XFCT=PARITY3(JR-J1C+J2C) + 1 *SQRT(F(J2R)*F(J2C)*F(P)*F(P2)*F(JR)*F(JC)*F(J1C)*F(J1R)) + 2 *THREEJ(J2R,P2,J2C)*XNINEJ(JC,JR,P,J1C,J1R,P1,J2C,J2R,P2) + 3 /4.D0/PI + 5201 X(ISTART-IX)=XCPL*XFCT + 5200 CONTINUE + IF (PRINT.GT.3) WRITE(6,695) IXMX + 695 FORMAT(/' CPL4 (JUL 93). JTOT-INDEPENDENT PARTS OF COUPLING', + 1 ' MATRIX STORED.'/ + 2 ' REQUIRED STORAGE =',I8) +C RESET MX, IFIRST TO REFLECT STORED VALUES + MX=MX-IXMX + IFIRST=0 +C +C NOW GET COUPLING MATRIX ELEMENTS FROM STORED PARTS + 5500 PJT=PARITY3(JTOT) + IF (IVLU.GT.0) REWIND IVLU + DO 5600 LL=1,MXLAM + P1 = LAM(4*LL-3) + Q1 = LAM(4*LL-2) + P2 = LAM(4*LL-1) + P = LAM(4*LL) +C + PPP = PARITY3(P) + IX1=(LL-1)*NL12 + NNZ=0 + IF (IVLU.EQ.0) THEN + IX=LL + ELSE + IX=1 + ENDIF +C + DO 5700 IC=1,N + INJ12P = J(IC) + JC=JLEV(INJ12P) + LC=L(IC) +C + DO 5700 IR=1,IC + INJ12=J(IR) + JR=JLEV(INJ12) + LR=L(IR) +C + XFACT = PJT*PPP*THREEJ(LR,P,LC)*SIXJ(LR,JR,LC,JC,JTOT,P) + 1 *SQRT(F(LR)*F(LC)) + IF (INJ12.GE.INJ12P) THEN + IX2=INJ12*(INJ12-1)/2+INJ12P + ELSE + IX2=INJ12P*(INJ12P-1)/2+INJ12 + ENDIF + INDX=IX1+IX2 +C + IF (X(ISTART-INDX).EQ.0.D0) THEN + VL(IX) = 0.D0 + ELSE + VL(IX)=XFACT*X(ISTART-INDX) + ENDIF + IF (VL(IX).NE.0.D0) NNZ=NNZ+1 + IF (IVLU.EQ.0) THEN + IX=IX+MXLAM + ELSE + IX=IX+1 + ENDIF + 5700 CONTINUE + IF (NNZ.EQ.0.AND.PRINT.GT.3) WRITE(6,697) P1,Q1,P2,P + IF (IVLU.GT.0) WRITE(IVLU) (VL(I),I=1,N*(N+1)/2) + 5600 CONTINUE + RETURN +C +C IF WE CANNOT STORE PARTIAL COUPLING MATRIX, RECALCULATE. + 5900 ASSIGN 3001 TO IGO1 + ASSIGN 3011 TO IGO2 + GO TO 3000 +C + ENTRY CPL24(N,MXLAM,LAM,NLEV,JLEV,ATAU,J,MVAL,VL,PRINT,LFIRST) +C +C IF LFIRST IS TRUE (FIRST CALL), DO SOME INITIALIZATION + IF (LFIRST) THEN + IFIRST=-1 + LFIRST=.FALSE. + NOMEM=.FALSE. + ENDIF +C + IF (IFIRST.GT.-1) GO TO 4500 +C FIRST TIME THROUGH SET UP SOME STORAGE POINTERS + NL12=NLEV*(NLEV+1)/2 + IXMX=NL12*MXLAM + ISTART=MX+1 +C + 4500 MVABS=IABS(MVAL) +C SEE IF VALUES ARE STORED FOR THIS HIGH AN MVALUE +C IF NOT, TRY TO STORE THEM IN XCPL(). + IF (MVABS.LE.IFIRST.OR.NOMEM) GO TO 4900 + MV=IFIRST+1 +C FIRST CHECK THAT WE STILL HAVE A CONTINUOUS BLOCK OF HI MEMORY. + 4600 IF (MX.EQ.ISTART-(IFIRST+1)*IXMX-1) GO TO 4610 + IF (PRINT.GE.1) WRITE(6,642) MV,ISTART-1,MX,IXMX*(IFIRST+1) + 642 FORMAT(/' CPL24 (JUL 93). HIGH MEMORY FRAGMENTED. CANNOT', + 1 ' STORE COUPLING COEFFS FOR MVAL=',I3/ 19X, + 2 'ORIGINAL MINUS CURRENT MEMORY LIMITS .NE. NO. USED =',3I12) + NOMEM=.TRUE. + GO TO 4900 +C TEST FOR AVAILABLE STORAGE; NEED IXMX FOR THIS MVAL + 4610 NAVAIL=MX-IXNEXT+1 + IF (IXMX.LE.NAVAIL) GO TO 4601 + IF (PRINT.GE.3) WRITE(6,692) MV,IXMX,NAVAIL + 692 FORMAT(/' CPL24 (JUL 93). UNABLE TO STORE 3-J VALUES FOR MVAL=' + 1 ,I3/' REQUIRED AND AVAILABLE STORAGE =',2I9) +C SET NOMEM TO REFLECT INABILITY TO ADD MORE M-VALUES + NOMEM=.TRUE. + GO TO 4900 +C +C REDUCE 'TOP OF MEMORY' AND STORE COUPLING VALUES FOR THIS MVAL + 4601 MX=MX-IXMX +C START INDEX AFTER M-BLOCKS ALREADY STORED (STARTING WITH MV=0) + IX=MV*IXMX + DO 4200 LL=1,MXLAM + P1 = LAM(4*LL-3) + Q1 = LAM(4*LL-2) + P2 = LAM(4*LL-1) + P = LAM(4*LL) + DO 4201 IC=1,NLEV + JC=JLEV(IC) + J1C = JLEV(IC+2*NLEV) + J2C = JLEV(IC+ NLEV) + ISTC=JLEV(IC+5*NLEV) + NKC=JLEV(IC+6*NLEV) + DO 4201 IR=1,IC + JR=JLEV(IR) + J1R = JLEV(IR+2*NLEV) + J2R = JLEV(IR+ NLEV) + ISTR=JLEV(IR+5*NLEV) + NKR=JLEV(IR+6*NLEV) + IX=IX+1 + XCPL=Z0 + KKC=-J1C + DO 4300 KC=1,NKC +C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. + IF (ABS(ATAU(ISTC+KC)).LE.EPS) GO TO 4300 + KKR=-J1R + DO 4400 KR=1,NKR +C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. + IF (ABS(ATAU(ISTR+KR)).LE.EPS) GO TO 4400 + AF=ATAU(ISTR+KR)*ATAU(ISTC+KC) + IF (KKR-KKC.NE.Q1) GO TO 4401 + XCPL=XCPL+AF*RSYMTP(J1R,KKR,J2R,J1C,KKC,J2C, + 1 JR,JC,MVAL,P1,Q1,P2,P) + IF (Q1.EQ.0) GO TO 4400 + 4401 IF (KKC-KKR.NE.Q1) GO TO 4400 +C ADJUST FOR (-1)**MU IN POTENTIAL. . . +C AF=AF*PARITY3(MU) + IF (ODD(P1+Q1+P2+P)) AF = -AF + XCPL=XCPL+AF*RSYMTP(J1R,KKR,J2R,J1C,KKC,J2C, + 1 JR,JC,MVAL,P1,-Q1,P2,P) + 4400 KKR=KKR+1 + 4300 KKC=KKC+1 + 4201 X(ISTART-IX)=XCPL + 4200 CONTINUE + IF(PRINT.GT.3) WRITE(6,693) MV,IXMX,NAVAIL + 693 FORMAT(/' CPL24 (JUL 93). 3J VALUES STORED FOR MVALUE =',I3, + 1 /,' REQUIRED AND AVAILABLE STORAGE =',2I9) + IFIRST = MV +C SEE IF CURRENT MVALUE REQUIRES MORE STORED M-VALUES. + MV=MV+1 + IF (MV.LE.MVABS) GO TO 4600 +C + 4900 IF (MVABS.GT.IFIRST) GO TO 4800 +C MVABS.LE.IFIRST. COEFFS STORED. FILL VL() FROM XCPL + IXM=MVABS*IXMX + IF (IVLU.GT.0) REWIND IVLU + DO 4513 LL=1,MXLAM + P1 = LAM(4*LL-3) + Q1 = LAM(4*LL-2) + P2 = LAM(4*LL-1) + P = LAM(4*LL) + NNZ=0 + IF (IVLU.EQ.0) THEN + IX=LL + ELSE + IX=1 + ENDIF + DO 4503 ICOL=1,N + I1=J(ICOL) + JC=JLEV(I1) + DO 4503 IROW=1,ICOL + I2=J(IROW) + JR=JLEV(I2) + IF (I1.GT.I2) THEN + IX12=I1*(I1-1)/2+I2 + ELSE + IX12=I2*(I2-1)/2+I1 + ENDIF + IXX=IXM+(LL-1)*NL12+IX12 + VL(IX)=X(ISTART-IXX) +C WE HAVE STORED COUPLING FOR POSITIVE MVALUES; CORRECT IF NECESSARY +C FOR PARITY OF THRJ(JR,P ,JC, MVAL,0,-MVAL) + IF (MVAL.LT.0.AND.ODD(JC+JR+P )) VL(IX)=-VL(IX) + IF (VL(IX).NE.Z0) NNZ=NNZ+1 + IF (IVLU.EQ.0) THEN + IX=IX+MXLAM + ELSE + IX=IX+1 + ENDIF + 4503 CONTINUE + IF (NNZ.LE.0 .AND. PRINT.GT.3) WRITE(6,612) MVAL,LL + 612 FORMAT(' * * * NOTE. FOR MVALUE, SYM =',2I4,', ALL COUPLING ', + & 'COEFFICIENTS ARE 0.') + IF (IVLU.GT.0) WRITE(IVLU) (VL(I),I=1,N*(N+1)/2) + 4513 CONTINUE + RETURN +C +C MV.GT.IFIRST ==> VALUES NOT STORED. CALCULATE THEM VIA OLD CODE + 4800 ASSIGN 3002 TO IGO1 + ASSIGN 3022 TO IGO2 + GO TO 3000 +C +C -------------------- OLD CODE REJOINS HERE --------------------- +C + 3000 IF (IVLU.GT.0) REWIND IVLU +C +C ----- LOOP OVER RADIAL SURFACES ----- +C + DO 3100 LL=1,MXLAM + P1 = LAM(4*LL-3) + Q1 = LAM(4*LL-2) + P2 = LAM(4*LL-1) + P = LAM(4*LL) + NNZ=0 + IF (IVLU.EQ.0) THEN + IX=LL + ELSE + IX=1 + ENDIF +C + DO 3200 IC=1,N + JC = JLEV(J(IC) ) + J1C = JLEV(J(IC) + 2*NLEV) + J2C = JLEV(J(IC) + NLEV) + ISTC = JLEV(J(IC) + 5*NLEV) + NKC = JLEV(J(IC) + 6*NLEV) +C + DO 3200 IR=1,IC + JR = JLEV(J(IR) ) + J1R = JLEV(J(IR) + 2*NLEV) + J2R = JLEV(J(IR) + NLEV) + ISTR = JLEV(J(IR) + 5*NLEV) + NKR = JLEV(J(IR) + 6*NLEV) +C + VL(IX)=0.D0 + KKC=-J1C +C +C ----- LOOP OVER EXPANSION COEFFICIENTS. ----- +C ----- SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. ----- +C + DO 3300 KC=1,NKC + IF (ABS(ATAU(ISTC+KC)).LE.EPS) GO TO 3300 + KKR=-J1R +C + DO 3400 KR=1,NKR + IF (ABS(ATAU(ISTR+KR)).LE.EPS) GO TO 3400 + AF=ATAU(ISTR+KR)*ATAU(ISTC+KC) + IF (KKR-KKC.NE.Q1) GO TO 3500 + GO TO IGO1,(3001,3002) + 3001 VL(IX)=VL(IX)+AF + 1 *QSYMTP(J1R,KKR,J1C,KKC,J2R,J2C,L(IR),L(IC), + 2 JR,JC,JTOT,P1,Q1,P2,P) + GO TO 3009 + 3002 VL(IX)=VL(IX)+AF*RSYMTP(J1R,KKR,J2R,J1C,KKC,J2C, + 1 JR,JC,MVAL,P1,Q1,P2,P) + 3009 IF (Q1.EQ.0) GO TO 3400 + 3500 IF(KKC-KKR.NE.Q1) GO TO 3400 + AF = AF*PARITY3(P1+P2+P+Q1) + GO TO IGO2(3011,3022) + 3011 VL(IX)=VL(IX)+AF + 1 *QSYMTP(J1R,KKR,J1C,KKC,J2R,J2C,L(IR),L(IC), + 2 JR,JC,JTOT,P1,-Q1,P2,P) + GO TO 3400 + 3022 VL(IX)=VL(IX)+AF*RSYMTP(J1R,KKR,J2R,J1C,KKC,J2C, + 1 JR,JC,MVAL,P1,-Q1,P2,P) + 3400 KKR=KKR+1 +C + 3300 KKC=KKC+1 +C + IF (VL(IX).NE.0.D0) NNZ=NNZ+1 + IF(IVLU .EQ. 0) THEN + IX = IX + MXLAM + ELSE + IX = IX + 1 + ENDIF + 3200 CONTINUE + IF (NNZ.EQ.0.AND.PRINT.GT.3) WRITE(6,697) P1,Q1,P2,P + 697 FORMAT(' * * * NOTE. ALL COUPLING COEFFICIENTS ARE ZERO FOR P1, + & Q1, P2, P = ', 4I4) + 3100 CONTINUE + RETURN + END + SUBROUTINE CPLOUT(IV,V,N,NPOTL) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION IV(1), V(1) +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C +C THIS ROUTINE PRINTS OUT THE COUPLING MATRIX ELEMENTS. + WRITE(6,602) NPOTL + 602 FORMAT('0 COUPLING MATRIX ELEMENTS BETWEEN CHANNELS FOR',I4, + 1 ' SYMMETRIES.') + IF (IVLFL.GT.0) THEN + IMAX=0 + DO 1000 I=1,N + DO 1000 J=1,I + IMIN=IMAX+1 + IMAX=IMAX+NPOTL + WRITE(6,600) I,J + 600 FORMAT('0 FOR CHANNEL ',I3,' TO CHANNEL',I4) + WRITE(6,601) (IV(IJ),V(IJ),IJ=IMIN,IMAX) + 601 FORMAT(' ',7(I3,1X,F12.5)) + 1000 CONTINUE + ELSE + IMIN=0 + DO 2000 I=1,N + DO 2000 J=1,I + WRITE(6,600) I,J + WRITE(6,601) (LL,V(IMIN+LL),LL=1,NPOTL) + 2000 IMIN=IMIN+NPOTL + ENDIF + RETURN + END + SUBROUTINE DAPROP(U, Y, N, + & RBEGIN, REND, NSTEPS, IREAD, IWRITE, ISCRU, + & Y14, Y23, ESHIFT, DIAG, + & P, VL, IV, ERED, EINT, CENT, RMLMDA, + & MXLAM, NPOTL, ISTART, NODES) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C ROUTINE TO SOLVE THE CLOSE COUPLED EQUATIONS USING AN +C IMPROVED LOG DERIVATIVE ALGORITHM. THE DIAGONAL OF THE +C COUPLING MATRIX EVALUATED AT THE MIDPOINT OF EACH SECTOR +C IS USED AS A REFERENCE POTENTIAL FOR THE SECTOR. +C + LOGICAL IREAD,IWRITE + DIMENSION U(N,N),Y(N,N),Y14(N),Y23(N),ESHIFT(N),DIAG(N) + DIMENSION P(MXLAM),VL(2),IV(2),EINT(N),CENT(N) +C + NODES=0 + ESAVE=ERED + DO 20 I=1,N + ESHIFT(I)=EINT(I)-ERED + EINT(I)=0.D0 + 20 CONTINUE + ERED=0.D0 +C +C THIS VERSION USES A CONSTANT STEP SIZE THROUGHOUT THE +C INTEGRATION RANGE, WITH NSTEPS STEPS BETWEEN RBEGIN AND REND. +C + H=(REND-RBEGIN)/DBLE(2*NSTEPS) + D1=H*H/3.D0 + D2=2.D0*D1 + D4=-D1/16.D0 + HALF=0.5D0*H +C + IF (IREAD) GO TO 60 + NSAVE=0 + R=RBEGIN + CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) + DO 40 J=1,N + DO 40 I=J,N + U(I,J)=D1*U(I,J) + 40 CONTINUE + IF (IWRITE) WRITE (ISCRU) DIAG,U + GO TO 80 + 60 READ (ISCRU) DIAG,U + 80 CONTINUE +C +C ISTART=0/1 MEANS THAT INITIAL LOG DERIVATIVE MATRIX ISN'T/IS +C ALREADY IN Y. DEFAULT IS 0. +C + IF(ISTART.EQ.1) GO TO 140 + SGN=1.D0 + IF(REND.LT.RBEGIN) SGN=-1.D0 + DO 120 J=1,N + DO 100 I=J,N + 100 Y(I,J)=0.D0 + WREF=DIAG(J)+ESHIFT(J) + Y(J,J)=SGN*1.D30 + IF(WREF.GT.0.D0) Y(J,J)=SGN*SQRT(WREF) + 120 CONTINUE + 140 CONTINUE +C + DO 160 J=1,N + DO 160 I=J,N + Y(I,J)=H*Y(I,J)+U(I,J) + 160 CONTINUE +C + DO 500 KSTEP=1,NSTEPS + IF (IREAD) GO TO 260 + R=R+H + CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) + DO 200 J=1,N + DO 200 I=J,N + U(I,J)=D4*U(I,J) + 200 CONTINUE + DO 220 I=1,N + U(I,I)=0.125D0 + 220 CONTINUE + CALL SYMINV(U,N,N,KOUNT) + IF (KOUNT.GT.N) GO TO 900 + NSAVE=NSAVE+KOUNT + DO 240 I=1,N + U(I,I)=U(I,I)-8.D0 + 240 CONTINUE + IF (IWRITE) WRITE (ISCRU) DIAG,U + GO TO 280 + 260 READ (ISCRU) DIAG,U + 280 CONTINUE +C + DO 300 I=1,N + WREF=DIAG(I)+ESHIFT(I) + ARG=HALF*SQRT(ABS(WREF)) + IF (WREF.LT.0.D0) THEN + TN=TAN(ARG) + Y14(I)=ARG/TN-ARG*TN + Y23(I)=ARG/TN+ARG*TN + ELSE +C IF (WREF.GT.0.D0) THEN + TH=TANH(ARG) + Y14(I)=ARG/TH+ARG*TH + Y23(I)=ARG/TH-ARG*TH + ENDIF + U(I,I)=U(I,I)+2.D0*Y14(I) + Y14(I)=Y14(I)-D1*DIAG(I) + Y14(I)=MAX(Y14(I),0.D0) + Y(I,I)=Y(I,I)+Y14(I) + 300 CONTINUE +C + CALL SYMINV(Y,N,N,KOUNT) + IF (KOUNT.GT.N) GO TO 900 + NODES=NODES+KOUNT + DO 320 J=1,N + DO 320 I=J,N + Y(I,J)=U(I,J)-Y23(I)*Y(I,J)*Y23(J) + 320 CONTINUE + CALL SYMINV(Y,N,N,KOUNT) + IF (KOUNT.GT.N) GO TO 900 + NODES=NODES+KOUNT +C + IF (IREAD) GO TO 360 + R=R+H + CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) + IF (KSTEP.EQ.NSTEPS) D2=D1 + DO 340 J=1,N + DO 340 I=J,N + U(I,J)=D2*U(I,J) + 340 CONTINUE + IF (IWRITE) WRITE (ISCRU) U + GO TO 380 + 360 READ (ISCRU) U + 380 CONTINUE +C + DO 400 J=1,N + DO 400 I=J,N + Y(I,J)=U(I,J)-Y23(I)*Y(I,J)*Y23(J) + 400 CONTINUE + DO 420 I=1,N + Y(I,I)=Y(I,I)+Y14(I) + 420 CONTINUE + 500 CONTINUE +C + HI=1.D0/H + DO 520 J=1,N + DO 520 I=J,N + Y(I,J)=HI*Y(I,J) + Y(J,I)=Y(I,J) + 520 CONTINUE +C + DO 540 I=1,N + EINT(I)=ESHIFT(I)+ESAVE + 540 CONTINUE + ERED=ESAVE + IF(IWRITE) WRITE(ISCRU) NSAVE + IF(IREAD) READ (ISCRU) NSAVE + NODES=NODES-NSAVE + RETURN +C + 900 WRITE (6,1000) KSTEP +1000 FORMAT('0***** MATRIX INVERSION ERROR IN DAPROP AT ', + & 'STEP K = ',I6,' RUN HALTED.') + STOP + END + SUBROUTINE DASCAT(N, NSQ, MXLAM, NPOTL, + 1 SR, SI, U, VL, IV, EINT, CENT, WVEC, L, NB, + 2 P, Y1, Y2, Y3, Y4, + 3 ICODE, IPRINT, IC) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C *** --------------------------------------------------------------- +C *** ROUTINE TO PERFORM A SCATTERING CALCULATION USING DAPROP. +C *** ON EXIT SR AND SI CONTAIN THE S MATRIX. +C *** SR IS USED INTERNALLY TO HOLD THE LOG DERIVATIVE MATRIX +C *** IN ORDER TO ECONOMISE ON WORKSPACE. +C *** --------------------------------------------------------------- +C *** ICODE.EQ.2 FOR SUBSEQUENT ENERGIES. +C *** +C DIMENSION STATEMENTS FOR ARGUMENT LIST + DIMENSION U(NSQ),Y1(N),Y2(N),Y3(N),Y4(N) + DIMENSION P(MXLAM),VL(2),IV(2),SR(NSQ),SI(NSQ), + & EINT(N),CENT(N),WVEC(N),L(N),NB(N) +C + COMMON/DRIVE/STEST,STEPS,STABIL,CONV,RMIN,RMAX,XEPS,DR, + 1 DRMAX,RMID,TOLHI,RTURN,VTOL,ESHIFT,ERED,RMLMDA, + 2 NOPEN,JKEEP,ISCRU,MAXSTP +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C +C THE FOLLOWING VARIABLES FROM COMMON/DRIVE/ ARE USED WITH THIS +C PROPAGATOR: STEPS,RMIN,RMAX,ERED,RMLMDA,NOPEN,ISCRU +C + LOGICAL IREAD,IWRITE +C ---------------------------------------------------------------- +C SET UP TO USE UNIT (ISCRU) + IREAD = ICODE.EQ.2 .AND. ISCRU.GT.0 + IWRITE = ICODE.EQ.1 .AND. ISCRU.GT.0 +C --------------------------------------------------------------- +C +C CALCULATE WAVEVECTORS AND STEP SIZE +C + WMAX=0.D0 + NOPEN=0 + DO 20 I=1,N + DIF=ERED-EINT(I) + WVEC(I)=SIGN(SQRT(ABS(DIF)),DIF) + WMAX=MAX(WMAX,WVEC(I)) + NB(I)=I + IF (DIF.GT.0.D0) NOPEN=NOPEN+1 + 20 CONTINUE + IF (NOPEN.EQ.0) RETURN +C + IF (IREAD) GO TO 40 + PI=ACOS(-1.D0) + NSTEPS=WMAX*STEPS*(RMAX-RMIN)/PI + RBEGIN=RMIN + REND=RMAX + IF (IWRITE) WRITE (ISCRU) RBEGIN,REND,NSTEPS + GO TO 60 + 40 READ (ISCRU) RBEGIN,REND,NSTEPS + 60 CONTINUE + ISTART=0 +C +C PROPAGATE LOG DERIVATIVE MATRIX THROUGH THE SCATTERING REGION +C --------------------------------------------------------------- + IF(N.EQ.1) GOTO 90 + CALL DAPROP(U, SR, N, + & RBEGIN, REND, NSTEPS, IREAD, IWRITE, ISCRU, + & Y1, Y2, Y3, Y4, + & P, VL, IV, ERED, EINT, CENT, RMLMDA, + & MXLAM, NPOTL, ISTART, NODES) +C --------------------------------------------------------------- + IF (IPRINT.GE.3) WRITE (6,1000) RBEGIN,REND,NSTEPS +1000 FORMAT('0 DAPROP. LOG DERIVATIVE MATRIX INTEGRATED FROM ', + & F12.4,' TO ',F12.4,' IN ',I6,' STEPS.') +C +C SORT CHANNELS BY ASYMPTOTIC ENERGY +C + NM1=N-1 + DO 80 I=1,NM1 + IP1=I+1 + DO 80 J=IP1,N + IF (EINT(NB(I)).LE.EINT(NB(J))) GO TO 80 + IT=NB(I) + NB(I)=NB(J) + NB(J)=IT + 80 CONTINUE + GOTO 100 +C +C SPECIAL CASE FOR EFFICIENT SINGLE CHANNEL CALCULATIONS +C 1/21/93 CHANGES TO DYNAMIC STORAGE: N.B IT5 FROM STORAG IS +C PASSED AS ARGUMENT IC TO FOLLOW CODING IN EARLIER VERSIONS. +C + 90 NPT=NSTEPS+1 + ISVMEM=IXNEXT + IT1=IC + IT2=IT1+NPT + IT3=IT2+NPT + IT4=IT3+NPT + IT5=IT4+NPT + IC1=IT5+NPT + ITP=IT3 + IC2=ITP+NPT*MXLAM + IXNEXT=MAX0(IC1,IC2) + NUSED=0 + CALL CHKSTR(NUSED) + CALL ODPROP(SR, X(IT1), X(IT2), X(IT3), X(IT4), X(IT5), + & RBEGIN, REND, NPT, IREAD, IWRITE, ISCRU, + & X(ITP), VL, IV, ERED, EINT, CENT, RMLMDA, + & MXLAM, NPOTL, ISTART, NODES) +C RESTORE STORAGE POINTER TO RECOVER TEMPORARY STORAGE. + IXNEXT=ISVMEM +C --------------------------------------------------------------- + IF (IPRINT.GE.3) WRITE (6,1010) RBEGIN,REND,NSTEPS +1010 FORMAT('0 ODPROP. LOG DERIVATIVE INTEGRATED FROM ', + & F12.4,' TO ',F12.4,' IN ',I6,' STEPS.') +C +C CALCULATE K AND S MATRICES +C + 100 CALL YTOK(NB,WVEC,L,N,NOPEN,Y1,Y2,Y3,Y4,SR,SI,U,REND) + CALL KTOS(U,SR,SI,NOPEN) + RETURN + END + SUBROUTINE DASIZE(ILSU,MXREC) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE MXUSED,IX + PARAMETER (NREC=20000) + DIMENSION IX(6,NREC) + DIMENSION IR2(2),IS2(2) + EQUIVALENCE (R,IR1,IR2(1)),(S,IS1,IS2(1)) + COMMON /ASSVAR/IDA +C +C DYNAMIC STORAGE COMMON BLOCK ... +C NEEDED FOR NIPR; PREVIOUSLY PASSED IN COMMON /INTPAC/ + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C + DATA MAX/NREC/ +C + MXREC=MAX + ILSU=999 + WRITE(6,601) MAX + 601 FORMAT( ' *** *** NUMBER OF SIMULATED RECORDS =',I7) + RETURN +C + ENTRY DAOPEN + MXUSED=0 + WRITE(6,600) + 600 FORMAT(/' *** *** IN-CORE DA SIMULATION ROUTINE HAS CONTROL.', + 1 /' *** *** DA FILE WILL NOT BE USED.') +C + IF(NIPR.EQ.1 .OR. NIPR.EQ.2) GOTO 1000 + WRITE(6,602) NIPR + 602 FORMAT(' *** ERROR IN DASIZE/DAOPEN: NIPR =',I3,' INVALID') + STOP + 1000 RETURN +C + ENTRY DARD1(I1,I2,I3,I4,I5,I6) + I1=IX(1,IDA) + I2=IX(2,IDA) + I3=IX(3,IDA) + I4=IX(4,IDA) + I5=IX(5,IDA) + I6=IX(6,IDA) + RETURN +C + ENTRY DAWR1(I1,I2,I3,I4,I5,I6) + MXUSED=MAX0(MXUSED,IDA) + IX(1,IDA)=I1 + IX(2,IDA)=I2 + IX(3,IDA)=I3 + IX(4,IDA)=I4 + IX(5,IDA)=I5 + IX(6,IDA)=I6 + RETURN +C + ENTRY DARD2(I1,I2,X1,X2) + I1=IX(1,IDA) + I2=IX(2,IDA) + IF(NIPR.EQ.1) THEN + IR1=IX(3,IDA) + IS1=IX(4,IDA) + ELSE + IR2(1)=IX(3,IDA) + IR2(2)=IX(4,IDA) + IS2(1)=IX(5,IDA) + IS2(2)=IX(6,IDA) + ENDIF + X1=R + X2=S + RETURN +C + ENTRY DAWR2(I1,I2,X1,X2) + MXUSED=MAX0(MXUSED,IDA) + IX(1,IDA)=I1 + IX(2,IDA)=I2 + R=X1 + S=X2 + IF(NIPR.EQ.1) THEN + IX(3,IDA)=IR1 + IX(4,IDA)=IS1 + ELSE + IX(3,IDA)=IR2(1) + IX(4,IDA)=IR2(2) + IX(5,IDA)=IS2(1) + IX(6,IDA)=IS2(2) + ENDIF + RETURN +C + ENTRY DACLOS + WRITE(6,610) MXUSED,MAX + 610 FORMAT(/' *** IN-CORE DA SIMULATOR USED',I10,' OF THE',I10, + 1 ' ALLOCATED RECORDS') + RETURN + END + SUBROUTINE DELRD(DR,CDIAG,COFF,TOL,DRMAX,E1,EN,RNOW,RMAX) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C------------------------------------------------------------------- +C THIS ROUTINE IS MODIFIED VERSION OF ROY GORDON'S QCPE PROGRAM. +C THIS VERSION FOR SCATTERING CALCULATION +C------------------------------------------------------------------- +C ADJUST THE STEP SIZE TO TRY TO KEEP MAX(CDIAG,COFF) = TOL + RTOL = 0.80D0*TOL +C------------------------------------------------------------------- +C FIND CORRECTION FACTOR FROM DIAGONAL PERTURBATIONS +C------------------------------------------------------------------- + IF (CDIAG .NE. 0.D0) GO TO 100 +C------------------------------------------------------------------- +C CASE IN WHICH DIAGONAL PERTURBATIONS VANISH +C------------------------------------------------------------------- + DFACT = 2.5D0 + GO TO 110 +C------------------------------------------------------------------- +C DIAGONAL PERTURBATIONS VARY ROUGHLY AS THE FIFTH POWER OF STEP SIZE +C------------------------------------------------------------------- + 100 DFACT = (RTOL/CDIAG)**0.333D0 +C------------------------------------------------------------------- +C FIND CORRECTION FACTOR FROM OFF-DIAGONAL PERTURBATIONS +C------------------------------------------------------------------- + 110 IF (COFF .NE. 0.D0) GO TO 120 +C------------------------------------------------------------------- +C CASE IN WHICH OFF-DIAGONAL PERTURBATIONS VANISH +C------------------------------------------------------------------- + OFACT = 2.5D0 + GO TO 130 +C------------------------------------------------------------------- +C OFF-DIAGONAL PERTURBATIONS VARY ROUGHLY AS CUBE OF STEP SIZE +C------------------------------------------------------------------- + 120 OFACT = (RTOL/COFF)**0.333D0 +C------------------------------------------------------------------- +C FIND MINIMUM FACTOR +C------------------------------------------------------------------- + 130 FACTOR = MIN(DFACT,OFACT) + IF (EN .GT. 0.D0) GO TO 150 + IF (E1 .GT. 0.D0) GO TO 140 +C------------------------------------------------------------------- +C THIS IS REACHED ONLY WHEN ALL CHANNELS ARE IN THEIR CLASSICALLY +C FORBIDDEN REGIONS. THEN ACCURACY IS QUITE SENSITIVE TO CHANGES +C IN STEP SIZE. +C HENCE IN THIS REGION MAKE ONLY CAUTIOUS CHANGES IN STEP SIZE +C------------------------------------------------------------------- + IF (FACTOR .GT. 1.15D0) FACTOR = 1.15D0 + GO TO 170 +C------------------------------------------------------------------- +C THIS IS REACHED WHEN SOME CHANNELS ARE CLASSICAL AND OTHERS NOT +C------------------------------------------------------------------- + 140 IF (FACTOR .GT. 1.20D0) FACTOR = 1.20D0 + GO TO 170 +C------------------------------------------------------------------- +C THIS IS REACHED WHEN ALL CHANNELS ARE CLASSICAL. +C THEN THE STEP SIZE IS OFTEN INCREASING RAPIDLY, AND ALSO THE +C ACCURACY VARIES MORE SLOWLY WITH STEP SIZE. +C THUS WE MAKE BOLDER INCREASES IN THE STEP SIZE, TO KEEP THE +C CORRECTIONS OF THE SAME ORDER OF MAGNITUDE AS BEFORE +C TEST TO SEE HOW FAR WE HAVE INTEGRATED +C------------------------------------------------------------------- + 150 IF (RNOW .GT. (0.10D0*RMAX)) GO TO 160 + IF (FACTOR .GT. 1.6D0) FACTOR = 1.6D0 + GO TO 170 +C------------------------------------------------------------------- +C CHOOSE FACTOR IN FAR AYSMPTOTIC REGION +C------------------------------------------------------------------- + 160 IF (FACTOR .GT. 2.5D0) FACTOR = 2.5D0 +C------------------------------------------------------------------- +C SET NEW STEP SIZE +C------------------------------------------------------------------- + 170 DR = DR*FACTOR +C------------------------------------------------------------------- +C CHECK AGAINST DRMAX AND EXCESSIVE GROWTH OF CLOSED CHANNELS +C------------------------------------------------------------------- + IF (EN .GE. 0.D0) GO TO 175 + DREXP = 4.D0/SQRT(-EN) + IF (DR .GT. DREXP) DR = DREXP + 175 IF (DR .GT. DRMAX) DR = DRMAX + IF (DR .LT. 1.0D-06*DRMAX) GO TO 180 + RETURN + 180 WRITE (6,1000) DR,CDIAG,COFF,TOL,DRMAX,E1,EN,RNOW,RMAX + STOP +C------------------------------------------------------------------- +C FORMATS +C------------------------------------------------------------------- + 1000 FORMAT('0 * * * ERROR IN DELRD. STEP SIZE =',E20.6, + 1 ' IS TOO SMALL'/'0',24X,'PARAMETERS PASSED ARE', + 2 ' CDIAG, COFF, TOL, DRMAX, E1, EN, RNOW, RMAX'/ + 4 25X,9(E10.3,1X)) +C----------------***END-DELRD***------------------------------------ + END + SUBROUTINE DERMAT(IDER,W,N,R,P,VL,IV,CENT,RMLMDA, + 1 MXLAM,NPOTL,NUMDER) +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE RSAVE + LOGICAL NUMDER +C +C EVALUATES THE IDER'TH DERIVATIVE OF THE POTENTIAL MATRIX AT RADIUS +C W = VCOUPL + VCENT +C ORDER OF THE REAL SYMMETRIC MATRIX W IS N +C THE FULL MATRIX IS COMPUTED +C VL IS THE PREVIOUSLY COMPUTED MATRIX OF THE COUPLING POTENTIAL +C IV IS AN INDEX ARRAY MAPPING P ONTO VL, SUCH THAT VL(I) IS +C A COEFFICIENT TO MULTIPLY P(IV(I)) +C CENT(I) IS L*(L+1) FOR THE I-TH CHANNEL +C RMLMDA IS THE SQUARE OF THE RATIO OF RM TO THE DEBROGLIE +C WAVELENGTH AT RELATIVE ENERGY EPSILON +C RMLMDA = 2.*URED*RM**2*EPSIL/HBAR**2 +C RMLMDA MULTIPLIES THE POTENTIAL IN UNITS OF EPSIL +C + DIMENSION W(N,N),VL(1),IV(1),CENT(N),P(MXLAM) + DATA DEL/1.D-3/, RSAVE/-999.D0/ +C + IF(NUMDER) GOTO 5 +C +C COMPUTE THE RADIAL PARTS OF THE POTENTIAL ANALYTICALLY + CALL POTENL(IDER,MXLAM,NPOTL,IDUM1,R,P,IDUM2) + +C IDUM1 AND IDUM2 ARE DUMMY ARGUMENTS HERE. + GOTO 14 +C +C NUMERICAL DERIVATIVE OPTION. +C NOTE THAT IF IDER = 2 THIS ASSUMES THAT +C THE POTENTIAL ITSELF IS ALREADY IS ALREADY IN THE FIRST +C MXLAM ELEMENTS OF P. THIS IS NOT TRUE IF DERMAT HAS BEEN +C CALLED MORE RECENTLY THAN WAVMAT, SO THE IDER = 2 CALL +C MUST PRECEDE THE IDER = 1 CALL. +C +C FIRST SEE WHETHER DERMAT HAS BEEN CALLED BEFORE FOR THIS +C VALUE OF R, AND IF SO SKIP POTENTIAL EVALUATIONS +C + 5 IF(R.EQ.RSAVE) GOTO 8 + RSAVE=R + RR=R-DEL + CALL POTENL(0,MXLAM,NPOTL,IDUM1,RR,P(MXLAM+1),IDUM2) + RR=R+DEL + CALL POTENL(0,MXLAM,NPOTL,IDUM1,RR,P(2*MXLAM+1),IDUM2) +C + 8 DO 10 I=1,MXLAM + P1=P(MXLAM+I) + P2=P(2*MXLAM+I) + IF(IDER.EQ.1) P(I) = (P2-P1)/(2.D0*DEL) + 10 IF(IDER.EQ.2) P(I) = (P2+P1-2.D0*P(I)/RMLMDA)/(DEL*DEL) +C + 14 DO 15 I=1,MXLAM + 15 P(I)=RMLMDA*P(I) +C + CALL WAVVEC(VL,P,IV,W,N,NPOTL) +C +C NOW COMPUTE THE DIAGONAL CONTRIBUTIONS W(I,I). +C + IF(IDER.EQ.1) RSQ=-2.D0/R**3 + IF(IDER.EQ.2) RSQ= 6.D0/R**4 + DO 20 I=1,N + W(I,I) = W(I,I) + RSQ*CENT(I) + 20 CONTINUE + RETURN + END + SUBROUTINE DGEMUL(A,LDA,TRANSA,B,LDB,TRANSB,C,LDC,L,M,N) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + CHARACTER*1 TRANSA,TRANSB + CALL DGEMM(TRANSA,TRANSB,L,N,M,1.D0,A,LDA,B,LDB,0.D0,C,LDC) + RETURN + END + SUBROUTINE DMSYM(J,NK,EVAL,EVEC,EVEC2,WKS) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE SYMPRT + PARAMETER (IDMAX=3) + LOGICAL SYMPRT + CHARACTER*1 CSUB,REPNAM(3) + DIMENSION SMAT(IDMAX,IDMAX),SVEC(IDMAX,IDMAX),SIG(IDMAX) + DIMENSION EVAL(NK),EVEC(-J:J,NK),EVEC2(-J:J,NK),WKS(NK) + DATA SYMPRT/.FALSE./ + DATA REPNAM/'A','E','F'/ + DATA TOL/1.D-8/ +C +C THE MATRIX DIAGONALISATION MAY RETURN EIGENVECTORS THAT ARE +C AWKWARD LINEAR COMBINATIONS OF DEGENERATE PAIRS/SETS. +C THIS ROUTINE FINDS SYMMETRISED COMBINATIONS +C THAT ARE EITHER EVEN OR ODD WITH RESPECT TO K -> -K +C BY CONSTRUCTING AND DIAGONALISING THE MATRIX REPRESENTATION +C OF SIGMA(XZ) FOR EACH DEGENERATE SET. +C + IMAX=0 + DO 1000 IC=1,NK + IF(IC.LE.IMAX) GOTO 1000 +C +C LOOK FOR DEGENERATE EIGENVECTORS +C + DO 200 JC=IC,NK + IF(ABS(EVAL(JC)-EVAL(IC)).GT.TOL) GOTO 200 + IMAX=JC + 200 CONTINUE +C + IDEG=1+IMAX-IC + IF(IDEG.GT.IDMAX) GOTO 1100 + IF(IDEG.EQ.1) GOTO 920 + IF(IDEG.GE.3) SYMPRT=.TRUE. +C +C NOW CONSTRUCT THE MATRIX REPRESENTATION +C + DO 400 L=1,IDEG + LC=IC+L-1 + DO 400 M=1,IDEG + MC=IC+M-1 + SMAT(M,L)=0.D0 + DO 400 K=-J,J + SMAT(M,L)=SMAT(M,L)+EVEC(K,MC)*EVEC(-K,LC) + 400 CONTINUE +C + IFAIL=0 + CALL F02ABF(SMAT,IDMAX,IDEG,SIG,SVEC,IDMAX,WKS,IFAIL) +C +C COPY OLD EIGENVECTORS INTO SIG AND CONSTRUCT NEW ONES +C + DO 500 L=1,IDEG + LC=IC+L-1 + DO 500 K=-J,J + EVEC2(K,L)=EVEC(K,LC) + 500 CONTINUE +C + DO 600 L=1,IDEG + LC=IC+L-1 + DO 600 K=-J,J + EVEC(K,LC)=0.D0 + DO 600 M=1,IDEG + EVEC(K,LC)=EVEC(K,LC)+SVEC(M,L)*EVEC2(K,M) + 600 CONTINUE +C +C THERE IS STILL A POSSIBILITY THAT EVEN AND ODD K ARE MIXED, +C BUT ONLY FOR TWO ADJACENT EIGENVECTORS. CHECK FOR THIS +C AND FIX IT IF IT IS FOUND +C + DO 900 L=1,IDEG-1 + LC=IC+L-1 + DO 700 K=-J,J-1 + IF(ABS(EVEC(K,LC)*EVEC(K+1,LC)).LT.TOL) GOTO 700 + THETA=ATAN2(EVEC(K,LC),EVEC(K,LC+1)) + CO=COS(THETA) + SI=SIN(THETA) + GOTO 800 + 700 CONTINUE + GOTO 900 + + 800 CONTINUE +C +C ARRIVE HERE IF THERE IS MIXING +C + DO 850 K=-J,J + TEMP =CO*EVEC(K,LC)-SI*EVEC(K,LC+1) + EVEC(K,LC)=SI*EVEC(K,LC)+CO*EVEC(K,LC+1) + EVEC(K,LC+1)=TEMP + 850 CONTINUE + 900 CONTINUE +C +C SPECIAL CODE TO WORK OUT SYMMETRY LABEL FOR SPHERICAL TOP +C + 920 IF(.NOT.SYMPRT) GOTO 1000 + CSUB=' ' + IF(IDEG.EQ.2) GOTO 950 + CSUB='1' + IF(J.LT.2) GOTO 950 + DO 940 L=1,IDEG + LC=IC+L-1 + IF(EVEC(2,LC)**2.GT.TOL) CSUB='2' + 940 CONTINUE +C + 950 WRITE(6,601) EVAL(LC),REPNAM(IDEG),CSUB + 601 FORMAT(' ENERGY LEVEL AT',F12.5,' HAS SYMMETRY ',2A1) +C + 1000 CONTINUE + RETURN +C + 1100 WRITE(6,699) IDEG,IDMAX + STOP + 699 FORMAT('0*** ERROR IN DMSYM: DEGENERACY',I3,' IS TOO LARGE ', + 1 'FOR DIMENSION IDMAX =',I3) + END + SUBROUTINE DSYFIL(UPLO, N, A, LDA) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + CHARACTER*1 UPLO + DIMENSION A(LDA,N) +C +C SUBROUTINE TO FILL IN THE SECOND TRIANGLE OF A SYMMETRIC MATRIX. +C IF UPLO='L', THE LOWER TRIANGLE IS FILLED IN +C IF UPLO='U', THE UPPER TRIANGLE IS FILLED IN +C + IF(UPLO.EQ.'L') THEN + DO 10 J=1,N-1 + 10 CALL DCOPY(N-J,A(J,J+1),LDA,A(J+1,J),1) + ELSEIF(UPLO.EQ.'U') THEN + DO 20 J=1,N-1 + 20 CALL DCOPY(N-J,A(J+1,J),1,A(J,J+1),LDA) + ENDIF +C + RETURN + END + SUBROUTINE DVFREE(UJ,UJP,UN,UNP,WRONS,L,N,WV,R,NB) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C DOUBLE PRECISION ASYMPTOTIC FUNCTIONS FOR MATCHING TO S-MATRIX. + DIMENSION UJ(N),UJP(N),UN(N),UNP(N),WRONS(N),WV(N) + DIMENSION L(N),NB(N) + DO 3000 I=1,N + NX=NB(I) + DW=WV(NX) + DARG=DW*R + CALL RBES(L(NX),DARG,UJ(NX),UJP(NX),UN(NX),UNP(NX)) + UJP(NX)=UJP(NX)*DW + UNP(NX)=UNP(NX)*DW + 3000 WRONS(NX)=(UJ(NX)*UNP(NX)-UJP(NX)*UN(NX))/SQRT(DW) + RETURN + END + SUBROUTINE DVSCAT(N,NSQ,MXLAM,NPOTL, + 1 SR,SI,A,VL,IV,EINT,CENT,WV,L,NB, + 2 P,Y,YP,F,XM,YM,DIAG,ESHIFT,ICODE,PRINT) +C +C DEVOGELAERE INTEGRATION (DOUBLE PRECISION) +C INCLUDING START ROUTINE, SUPPRESSION OF CLOSED-CHANNEL GROWTH +C AND S-MATRIX DETERMINATION IN ASYMPTOTIC LIMIT. +C FOLLOWS OUTLINE OF PAUL MCGUIRE'S PROGRAM. +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + LOGICAL IREAD,IWRITE,END + INTEGER L(N),NB(N),IV(1) + INTEGER PRINT + DIMENSION Y(NSQ,4),YP(NSQ,2),F(NSQ,4),A(NSQ),XM(NSQ),YM(NSQ), + 1 DIAG(N),P(MXLAM),SR(NSQ),SI(NSQ),VL(2),EINT(N),CENT(N),WV(N) + DIMENSION R(4) +C +C INDICES ON Y, YP, F ARE (ITH SOLN. COMP, NTH SOLN, KTH R-VALUE) +C +C COMMON FROM DRIVER + COMMON/DRIVE/STEST,STEPS,STAB,CONV,RMIN,RMAX,DUMMY(8), + 1 ERED,RMLMDA,NOPEN,JKEEP,ISCRU,MAXSTP +C +C STEPS IS NO. OF STEPS PER (SHORTEST) WAVELENGTH. +C STAB IS NUMBER OF STEPS TAKEN BEFORE STABILIZATION. +C +C MAX. NUMBER OF TRIALS TO CONVERGE S-MATRIX IN ASYMPTOTIC REGION. + DATA MXSTRY/20/ +C + IREAD = ICODE.EQ.2 .AND. ISCRU.GT.0 + IWRITE = ICODE.EQ.1 .AND. ISCRU.GT.0 + IF(IREAD .AND. PRINT.GE.5) WRITE(6,668) + 668 FORMAT('0 DEVOGELAERE PROPAGATION WILL USE STORED INITIAL R,', + 1 ' STEP SIZE AND POTENTIAL MATRICES') +C +C ZERO STORAGE . . . +C + NP1=N+1 + DO 800 IJ=1,NSQ + SR(IJ)=0.D0 + 800 SI(IJ)=0.D0 + DO 900 I=1,2 + DO 900 IJ=1,NSQ + 900 YP(IJ,I)=0.D0 + DO 1000 I=1,4 + DO 1000 IJ=1,NSQ + Y(IJ,I)=0.D0 + 1000 F(IJ,I)=0.D0 +C + NSTRY=0 + RMSAVE=RMAX +C +C ********** START INTEGRATION ********** + CALL DVSTRT(RMIN,STEPS,ERED,RMLMDA,N,MXLAM,NPOTL,NOPEN,PRINT, + & A,DIAG,P,VL,IV,EINT,CENT,NB,WV,Y(1,2),YP(1,1),HH, + & ISCRU,IREAD,IWRITE) + IF (NOPEN.LE.0) GOTO 9000 + NSTAB=STAB + NSTAB=MAX0(NSTAB,1) + H2=HH/2.D0 + R(2)=RMIN + NSTEP=1 +C GET F(,,2) FROM Y(,,2) + R4=R(2) + IF(.NOT.IREAD) GOTO 1200 + READ(ISCRU) A + DO 1100 IJ=1,NSQ,NP1 + 1100 A(IJ)=A(IJ)-ESHIFT + GOTO 1300 + 1200 CALL WAVMAT(A,N,R4,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, + 1 MXLAM,NPOTL) + IF(IWRITE) WRITE(ISCRU) A + 1300 CALL DSYMM('L','L',N,N,1.D0,A,N,Y(1,2),N,0.D0,F(1,2),N) + CALL DAXPY(NSQ,1.D0,F(1,2),1,Y(1,2),1) + CALL DAXPY(NSQ,-H2,YP(1,1),1,Y(1,1),1) + CALL DAXPY(NSQ,0.5D0*H2*H2,F(1,2),1,Y(1,1),1) +C GET F(,,1) FROM THIS Y(,,1). NEEDS POTENTIAL AT R(1) + R(1)=R(2)-H2 + R4=R(1) + IF(.NOT.IREAD) GOTO 1800 + READ(ISCRU) A + DO 1700 IJ=1,NSQ,NP1 + 1700 A(IJ)=A(IJ)-ESHIFT + GOTO 1900 + 1800 CALL WAVMAT(A,N,R4,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, + 1 MXLAM,NPOTL) + IF(IWRITE) WRITE(ISCRU) A + 1900 CALL DSYMM('L','L',N,N,1.D0,A,N,Y(1,1),N,0.D0,F(1,1),N) +C +C ********** MAIN BODY OF ITERATION ********** +C PROPAGATE FROM (-1/2) AND (0) TO (1/2) AND (1). + 2000 CONTINUE + CALL DAXPY(NSQ,1.D0,Y(1,2),1,Y(1,3),1) + CALL DAXPY(NSQ,H2,YP(1,1),1,Y(1,3),1) + CALL DAXPY(NSQ,H2*H2*4.D0/6.D0,F(1,2),1,Y(1,3),1) + CALL DAXPY(NSQ,-H2*H2/6.D0,F(1,1),1,Y(1,3),1) + R(3)=R(2)+H2 + R4=R(3) + IF(.NOT.IREAD) GOTO 2200 + READ(ISCRU) A + DO 2100 IJ=1,NSQ,NP1 + 2100 A(IJ)=A(IJ)-ESHIFT + GOTO 2300 + 2200 CALL WAVMAT(A,N,R4,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, + 1 MXLAM,NPOTL) + 2300 IF(IWRITE) WRITE(ISCRU) A + CALL DSYMM('L','L',N,N,1.D0,A,N,Y(1,3),N,0.D0,F(1,3),N) + CALL DAXPY(NSQ,1.D0,Y(1,2),1,Y(1,4),1) + CALL DAXPY(NSQ,HH,YP(1,1),1,Y(1,4),1) + CALL DAXPY(NSQ,HH*HH/6.D0,F(1,2),1,Y(1,4),1) + CALL DAXPY(NSQ,HH*HH/3.D0,F(1,3),1,Y(1,4),1) + R(4)=R(3)+H2 + R4=R(4) + IF(.NOT.IREAD) GOTO 2700 + READ(ISCRU) A + DO 2600 IJ=1,NSQ,NP1 + 2600 A(IJ)=A(IJ)-ESHIFT + GOTO 2800 + 2700 CALL WAVMAT(A,N,R4,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, + 1 MXLAM,NPOTL) + IF(IWRITE) WRITE(ISCRU) A + 2800 CALL DSYMM('L','L',N,N,1.D0,A,N,Y(1,4),N,0.D0,F(1,4),N) + CALL DAXPY(NSQ,1.D0,YP(1,1),1,YP(1,2),1) + CALL DAXPY(NSQ,HH/6.D0,F(1,2),1,YP(1,2),1) + CALL DAXPY(NSQ,HH/6.D0,F(1,4),1,YP(1,2),1) + CALL DAXPY(NSQ,HH*4.D0/6.D0,F(1,3),1,YP(1,2),1) + NSTEP=NSTEP+1 +C +C ********** THIS ENDS DEVOGELAERE CYCLE ********** +C + NOPLOC=0 + DO 2900 I=1,NSQ,NP1 + 2900 IF(A(I).LT.0.D0) NOPLOC=NOPLOC+1 +C + END=R4.GT.RMAX .AND. NOPLOC.GE.NOPEN + IF(IREAD) READ(ISCRU) END + IF(END) GOTO 3000 +C +C ********** STABILIZATION EVERY NSTAB STEPS ********** + 4000 IF(NSTEP-NSTAB*(NSTEP/NSTAB).NE.0) GOTO 5000 + IF (PRINT.GT.12) WRITE(6,673) R(4) + 673 FORMAT(' STABILIZATION DONE AT R =',E12.4) +C FIRST 2 COLS OF Y AND F AND ALSO A USED AS SCRATCH IN STABIL. + CALL STABIL(N,NB,Y(1,4),YP(1,2),F(1,3),F(1,4), + & A,Y(1,1),Y(1,2),F(1,1),F(1,2)) +C +C ********** RE-INITIALIZE FOR NEXT CYCLE OF INTEGRATION ********* + 5000 R(1)=R(3) + R(2)=R(4) + IF(IWRITE) WRITE(ISCRU) IREAD + CALL DCOPY(NSQ,YP(1,2),1,YP(1,1),1) + CALL DCOPY(NSQ,Y(1,3),1,Y(1,1),1) + CALL DCOPY(NSQ,Y(1,4),1,Y(1,2),1) + CALL DCOPY(NSQ,F(1,3),1,F(1,1),1) + CALL DCOPY(NSQ,F(1,4),1,F(1,2),1) + DO 5200 IJ=1,NSQ + YP(IJ,2)=0.D0 + Y(IJ,3)=0.D0 + 5200 Y(IJ,4)=0.D0 + GOTO 2000 +C + 3000 CONTINUE + IF ((PRINT.GE.2.AND.NSTRY.LE.0) .OR. PRINT.GE.12) + & WRITE(6,601) NSTEP,R(4) + 601 FORMAT(' INTEGRATION REACHED ASYMPTOTIC LIMIT IN', + & I5,' STEPS. R =',D12.4) +C +C ********** ASYMPTOTIC REGION - CALCULATE S-MATRIX ********** + NOPSQ=NOPEN*NOPEN +C USE FIRST 2 COLS OF Y AND F FOR REGULAR AND IRREGULAR BESSEL FNS. +C AND DERIVATIVES - UJ, UJP, UN, AND UNP. +C USE FIRST COL. OF A FOR WRONSKIAN/SQRT(WV). + CALL DVFREE(Y(1,1),Y(1,2),F(1,1),F(1,2),A,L,NOPEN,WV,R(4),NB) +C FORM TRANSPOSE OF X- AND Y- MATRICES + DO 3200 J=1,NOPEN + IJ=J + DO 3100 I=1,NOPEN + NX=NB(I) + NY=NX+N*(J-1) + XM(IJ)=(F(NX,2)*Y(NY,4)-F(NX,1)*YP(NY,2)) / A(NX) + YM(IJ)=(Y(NX,2)*Y(NY,4)-Y(NX,1)*YP(NY,2)) / A(NX) + 3100 IJ=IJ+NOPEN + 3200 CONTINUE +C GET K-MATRIX FROM SOLN TO LINEAR EQNS,REPLACES RHS + DO 3300 I=1,NOPSQ + 3300 A(I)=YM(I) + CALL DGESV(NOPEN,NOPEN,XM,NOPEN,Y,A,NOPEN,IER) + IF (IER.EQ.0) GOTO 3400 + WRITE(6,688) + 688 FORMAT('0 * * * WARNING. LOSS OF ACCURACY IN SOLVING FOR K.') + CALL OUTERR(11) +C +C FORCE SYMMETRY ON K-MATRIX AND CALCULATE S MATRIX +C + 3400 CALL RSYM(NOPEN, A, STEST, PRINT) + CALL KTOS(A,XM,YM,NOPEN) +C +C TEST FOR CONVERGENCE OF SR, SI +C + TEST=0.D0 + DO 3500 I=1,NOPSQ + TEST=MAX(TEST,ABS(SR(I)-XM(I)),ABS(SI(I)-YM(I))) + SR(I)=XM(I) + 3500 SI(I)=YM(I) +C + IF(IREAD) GOTO 9000 + IF(TEST.GT.STEST) GOTO 3600 + IF(PRINT.GE.2) WRITE(6,686) NSTRY,R(4),TEST + 686 FORMAT(' S-MATRIX CONVERGED AFTER',I3,' TRIES IN ', + & 'ASYMPTOTIC REGION. R =',D12.4,'. TEST =',E12.4) + GOTO 9000 + 3600 IF(NSTRY.GT.0 .AND. PRINT.GE.2) WRITE(6,687) NSTRY,R(4),TEST + 687 FORMAT(' S-MATRIX NOT CONVERGED AFTER',I3, + & ' TRIES. R =',D12.4,'. LARGEST CHANGE =',D12.4) + IF (NSTRY.LT.MXSTRY) GOTO 3700 +C SET 'CONV' FLAG FOR OUTPUT ROUTINE. . . + CONV=-1.D0 + GOTO 9000 + 3700 NSTRY=NSTRY+1 + RMAX=RMAX+STEPS*HH + GOTO 5000 +C +C COMMON RETURN POINT +C RESTORE RMAX + 9000 RMAX=RMSAVE + IF(IWRITE) WRITE(ISCRU) IWRITE + RETURN + END + SUBROUTINE DVSTRT(R,STEPS,ERED,RMLMDA,N,MXLAM,NPOTL,NOPEN,PRINT, + & W,DIAG,P,VL,IV,EINT,CENT,NB,WV,U,UP,HH,ISCRU,IREAD,IWRITE) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C + INTEGER PRINT + LOGICAL SURF,IREAD,IWRITE + DIMENSION W(N,N),DIAG(N),P(2),VL(2),IV(1),EINT(N),CENT(N),NB(N), + & WV(N),U(N,N),UP(N,N) +C +C PROVIDE STARTING SOLUTION AND DERIVATIVE FOR DEVOGELAERE. +C ALSO PICK STEP SIZE, HH. +C STEPS IS NO. OF STEPS PER (SHORTEST) WAVELENGTH. +C THIS IS SIMPLEST VERSION, SIMILAR TO THAT OF MCGUIRE. +C + RSAVE=R + SURF=R.LT.0.D0 + DRMIN=ABS(R/STEPS) +C +C * * * * * ORDER BASIS FUNCTIONS ON INCREASING INTERNAL ENERGY. + DO 3000 I=1,N + 3000 NB(I)=I + IF (N.LE.1) GO TO 1000 + NM1=N-1 + DO 3100 I=1,NM1 + IP1=I+1 + DO 3100 J=IP1,N + IF (EINT(NB(I)).LE.EINT(NB(J))) GO TO 3100 + IT=NB(I) + NB(I)=NB(J) + NB(J)=IT + 3100 CONTINUE +C +C * * * * * SEE THAT ALL CHANNELS (IN FREE BASIS) ARE CLOSED. + IF(IREAD) GOTO 2000 + 1000 CALL WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, + 1 MXLAM,NPOTL) + IF(PRINT.GT.12) WRITE(6,698) R,(P(I),I=1,MXLAM) + 698 FORMAT('0 POTENTIAL ARRAY AT R =',F10.4/(10(1X,D12.5))) + DO 1100 I=1,N + IF (PRINT.GT.12) WRITE(6,699) I,W(I,I) + 699 FORMAT(' FOR CHANNEL',I4, ' V(RMIN) - E =',D13.4) + IF (W(I,I).GT.0.D0) GO TO 1100 + R=R-DRMIN + IF(SURF .OR. R.GT.0.D0) GO TO 1000 + WRITE(6,600) + 600 FORMAT('0 * * * ERROR. RMIN LESS THAN ZERO IN DVSTRT.', + 1 ' POTENTIAL MAY BE UNPHYSICAL') + STOP + 1100 CONTINUE +C + IF(R.NE.RSAVE) WRITE(6,602)RSAVE,R + 602 FORMAT('0 * * * WARNING. DVSTRT HAS CHANGED RMIN FROM ',F6.2, + & ' TO ',F6.2,' TO ENSURE THAT ALL CHANNELS ARE LOCALLY CLOSED') +C +C * * * * * INITIALIZE U, UP. + 2000 DO 4000 I=1,N + DO 4000 J=1,N + U(I,J)=0.D0 + UP(I,J)=0.D0 + IF (I.EQ.NB(J)) UP(I,J)=1.D-8 + 4000 CONTINUE +C * * * * * INITIALIZE NOPEN, WV. PICK STEP SIZE. + NOPEN=0 + BIG=0.D0 + DO 5000 I=1,N + DIF=ERED-EINT(I) + IF (DIF.LE.0.D0) GO TO 5100 + NOPEN=NOPEN+1 + 5100 WV(I)=SIGN(SQRT(ABS(DIF)),DIF) + 5000 BIG=MAX(BIG,WV(I)) + IF (NOPEN.LE.0) RETURN +C CALCULATE STEP SIZE FROM LARGEST WVEC. + HH=3.1416D0/(BIG*STEPS) + IF(IWRITE) WRITE(ISCRU) R,HH + IF(IREAD) READ(ISCRU) R,HH + IF (PRINT.GE.2) WRITE(6,601) R,HH + 601 FORMAT('0 INTEGRATION STARTED AT RMIN =',D12.4, + & '. STEP SIZE =',D12.4) + RETURN + END + SUBROUTINE EAVG(NT,T,NGP,E,NNRG,MXNRG) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION E(1),T(1) + DIMENSION A(20),W(20) +C THIS ROUTINE SETS UP ENERGIES FOR NGP-POINT GAUSS-LAGUERRE INTEG. +C AT SPECIFIED TEMPERATURES (DEG. KELVIN). + DATA XK/.6950305D0/ + DATA A/.585786437627D0, 3.414213562373D0, + 2 0.415774556783D0, 2.294280360279D0, 6.289945082937D0, + 3 0.322547689619D0, 1.745761101158D0, 4.536620296921D0, + 4 9.395070912301D0, 0.263560319718D0, 1.413403059107D0, + 5 3.596425771041D0, 7.085810005859D0, 12.640800844276D0, + 6 6*0.D0/ + DATA W/ 0.853553390593D0, 0.146446609407D0, 0.711093009929D0, + 8 0.278517733569D0, 0.103892565016D-1, 0.603154104342D0, + 9 0.357418692438D0, 0.388879085150D-1, 0.539294705561D-3, + A 0.521755610583D0, 0.398666811083D0, 0.759424496817D-1, + B 0.361175867992D-2, 0.233699723858D-4, 6*0.D0/ + NGP=MAX0(2,MIN0(6,IABS(NGP))) + IST=NGP*(NGP-1)/2-1 + WRITE(6,600) NGP + 600 FORMAT('0 ENERGY VALUES WILL BE GENERATED TO FACILITATE',I4, + 1 '-POINT GAUSS-LAGUERRE INTEGRATION OVER BOLTZMANN DISTRIBUTION') + NN=0 + DO 1000 I=1,NT + IF (NN+NGP.LE.MXNRG) GO TO 1010 + WRITE(6,601) I,T(I) + 601 FORMAT('0 * * * WARNING. NOT ENOUGH SPACE IN ENERGY() TO PROCESS + 1TEMP(',I3,' ) =',F8.2) + GO TO 1000 + 1010 XT=XK*T(I) + WRITE(6,602) T(I),XT + 602 FORMAT('0 FOR TEMP =',F8.2,' DEG. K =',F8.2,' (1/CM), THE + 1AVERAGE IS APPROXIMATELY THE SUM OF') + DO 1100 J=1,NGP + EN=XT*A(IST+J) + WT=A(IST+J)*W(IST+J) + NN=NN+1 + E(NN)=EN + 1100 WRITE(6,603) WT,EN + 603 FORMAT(15X,F13.8, ' * SIG( E =',F12.4,' ) ') + 1000 CONTINUE + NNRG=MIN0(MXNRG,MAX0(NNRG,NN)) + RETURN + END + SUBROUTINE ECNV(EUNITS,EUNITC,TOCM) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C THIS ROUTINE ACCEPTS AN INTEGER, EUNITS, OR A CHARACTER*4, EUNITC, +C AND DETERMINES "UNITS" AND ACCORDINGLY A CONVERSION FACTOR TO (1/CM). +C EUNITC TAKES PRECEDENCE; VERSION OF 21 MAR 95 +C +C IMPLEMENTED UNITS ARE +C 1) 1/CM 2) DEG. K 3) MHZ 4) GHZ 5) EV 6) ERG 7) A.U. +C 8) KJ/MOL 9) KCAL/MOL +C INPUT MUST BE AN INTEGER (1-9) SPECIFYING THE CORRESPONDING UNIT +C OR A CHARACTER CODE (IN EUNITC) CORRESPONDING TO THE UNIT. +C +C ENERGY CONVERSION FACTORS TAKEN FROM E. R. COHEN AND B. N. TAYLOR, +C JOURNAL OF RESEARCH OF THE NBS 92, 85 (1987). +C + INTEGER EUNITS + CHARACTER*4 EUNITC,BLANKS + CHARACTER*8 LTYP(9) + DIMENSION ECONV(9) + DATA LTYP/' 1/CM',' K ',' MHZ',' GHZ',' EV ',' ERG', ' AU', + 1 'KJ/MOL','KCAL/MOL'/ + DATA BLANKS/' '/ + DATA ECONV/1.D0,0.6950387D0, 3.335640952D-5,3.335640952D-2, + 1 8065.5410D0,5.0341125D+15,219474.63067D0, + 2 83.593461D0,349.9891D0/ + DATA MXUNIT/9/ +C + IF (EUNITC.EQ.BLANKS) THEN + IF (EUNITS.EQ.0) THEN + WRITE(6,600) + 600 FORMAT(/' INPUT ENERGY VALUES ASSUMED TO BE IN UNITS OF ', + 1 '1/CM BY DEFAULT.') + TOCM=1.D0 + ELSEIF (EUNITS.GT.0.AND.EUNITS.LE.MXUNIT) THEN + IVAL=EUNITS + WRITE(6,601) LTYP(IVAL),IVAL + 601 FORMAT(/' INPUT ENERGY VALUES CONVERTED FROM ',A8,/5X,'TO', + 1 ' INTERNAL WORKING UNITS OF 1/CM DUE TO INTEGER INPUT =',I4) + TOCM=ECONV(IVAL) + ELSE + WRITE(6,699) EUNITS,(I,LTYP(I),I=1,MXUNIT) + 699 FORMAT(/' *** ECNV. INPUT EUNITS = ',I6,' CANNOT BE ', + 1 'PROCESSED. ALLOWED VALUES ARE'/(11X,I2,2X,A8/)) + STOP + ENDIF + ELSE + CALL ECNVX(EUNITC,IVAL) + TOCM=ECONV(IVAL) + ENDIF + RETURN + END + SUBROUTINE ECNVX(EUNITS,IVAL) +C +C THIS ROUTINE CONVERTS A 4 CHARACTER INPUT -- EUNITS -- +C INTO THE CORRESPONDING INTEGER VALUE -- IVAL. +C VERSION OF 21 MAR 95. +C IMPLEMENTED UNITS ARE +C 1) 1/CM 2) DEG. K 3) MHZ 4) GHZ 5) EV 6) ERG 7) A.U. +C 8) KJ/MOL 9) KCAL/MOL +C + LOGICAL STSRCH + CHARACTER*1 L4(4),C,M,K,H,Z,E,V,R,G,A,U,L,J, + 1 LC,LM,LK,LH,LZ,LE,LV,LR,LG,LA,LU,LL,LJ + CHARACTER*4 EUNITS + CHARACTER*8 LTYP(9) + DATA LTYP/' 1/CM',' K ',' MHZ',' GHZ',' EV ',' ERG', ' AU', + 1 'KJ/MOL','KCAL/MOL'/ + DATA MX/9/ + DATA C/'C'/,M/'M'/,K/'K'/,H/'H'/,Z/'Z'/,E/'E'/,V/'V'/, + 2 R/'R'/, G/'G'/, A/'A'/, U/'U'/, L/'L'/, J/'J'/, + 3 LC/'c'/,LM/'m'/,LK/'k'/,LH/'h'/,LZ/'z'/,LE/'e'/,LV/'v'/, + 4 LR/'r'/,LG/'g'/,LA/'a'/,LU/'u'/,LL/'l'/,LJ/'j'/ +C PUT CHARACTERS OF EUNITS INTO ARRAY L4 + L4(1)=EUNITS(1:1) + L4(2)=EUNITS(2:2) + L4(3)=EUNITS(3:3) + L4(4)=EUNITS(4:4) +C + 2000 DO 2001 II=1,4 +C SEARCH FOR ONE OF ALLOWED 1ST LETTERS. . . + IF (L4(II).EQ.C.OR.L4(II).EQ.LC) GO TO 3001 + IF (L4(II).EQ.K.OR.L4(II).EQ.LK) GO TO 3002 + IF (L4(II).EQ.M.OR.L4(II).EQ.LM) GO TO 3003 + IF (L4(II).EQ.G.OR.L4(II).EQ.LG) GO TO 3004 + IF (L4(II).EQ.E.OR.L4(II).EQ.LE) GO TO 3005 + 2001 IF (L4(II).EQ.A.OR.L4(II).EQ.LA) GO TO 3006 + GO TO 2991 +C FOR EACH ALLOWED FIRST LETTER, SEARCH FOR NEXT IN KEYWORDS. . . + 3001 IF(.NOT.STSRCH(M,LM,L4(II+1),4-II,IF)) GO TO 2991 + IT=1 + GO TO 5000 +C + 3002 IF (.NOT.STSRCH(C,LC,L4(II+1),4-II,IF)) GO TO 3012 + IFN=II+IF + IF (.NOT.STSRCH(A,LA,L4(IFN+1),4-IFN,IF)) GO TO 2991 + IFN=IFN+IF + IF (.NOT.STSRCH(L,LL,L4(IFN+1),4-IFN,IF)) GO TO 2991 + IT=9 + GO TO 5000 + 3012 IF (.NOT.STSRCH(J,LJ,L4(II+1),4-II,IF)) GO TO 3022 + IT=8 + GO TO 5000 + 3022 IT=2 + GO TO 5000 + 3003 IF(.NOT.STSRCH(H,LH,L4(II+1),4-II,IF)) GO TO 2991 + IF (.NOT.STSRCH(Z,LZ,L4(II+IF+1),4-II-IF,IF)) GO TO 2991 + IT=3 + GO TO 5000 + 3004 IF(.NOT.STSRCH(H,LH,L4(II+1),4-II,IF)) GO TO 2991 + IF (.NOT.STSRCH(Z,LZ,L4(II+IF+1),4-II-IF,IF)) GO TO 2991 + IT=4 + GO TO 5000 + 3005 IF (.NOT.STSRCH(V,LV,L4(II+1),4-II,IF)) GO TO 3015 + IT=5 + GO TO 5000 + 3015 IF (.NOT.STSRCH(R,LR,L4(II+1),4-II,IF)) GO TO 2991 + IF (.NOT.STSRCH(G,LG,L4(II+IF+1),4-II-IF,IF)) GO TO 2991 + IT=6 + GO TO 5000 + 3006 IF (.NOT.STSRCH(U,LU,L4(II+1),4-II,IF)) GO TO 2991 + IT=7 + GO TO 5000 + 2991 CONTINUE +C + WRITE(6,699) EUNITS,(LTYP(I),I=1,MX) + 699 FORMAT(/' *** ECNVX. EUNITC INPUT = ',A4,' CANNOT BE PROCESSED.' + 1 , ' ALLOWED TYPES ARE'/(10X,A8)) + STOP +C + 5000 IVAL=IT + WRITE(6,602) LTYP(IT),EUNITS + 602 FORMAT(/' INPUT ENERGY VALUES CONVERTED FROM ',A8,/5X,'TO ' + 1 ,'INTERNAL WORKING UNITS OF 1/CM DUE TO ALPHAMERIC INPUT =',A4) + RETURN + END + FUNCTION EPSUM(R,N,E,EVEC,WKS) +C +C FUNCTION TO EVALUATE THE EIGENPHASE SUM FROM THE R-MATRIX. +C F02ABF DIAGONALISES THE N X N REAL SYMMETRIC R-MATRIX, +C RETURNING THE EIGENVALUES IN E. +C THE EIGENPHASE SUM IS THEN OBTAINED BY SUMMING ARCTANGENTS +C OF THE EIGENVALUES. +C THE RESULT IS RETURNED IN UNITS OF PI, AND IS SHIFTED TO BE +C AS CLOSE AS POSSIBLE TO THE PREVIOUS EIGENPHASE SUM CALCULATED +C (STORED IN SMLAST) +C SEE ASHTON, CHILD AND HUTSON, J. CHEM. PHYS. 78, 4025 (1983). +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE SMLAST + DIMENSION R(N,N), E(N), EVEC(N,N), WKS(N) + DATA PI/3.141592653589793238462643D0/ + DATA SMLAST/10.D0/ +C + IF(N.EQ.1) GOTO 200 + IFAIL=0 + CALL F02ABF(R,N,N,E,EVEC,N,WKS,IFAIL) + EPSUM=0.D0 + DO 100 I=1,N + X=ATAN(E(I)) + EPSUM=EPSUM+X + 100 CONTINUE + GOTO 300 + 200 EPSUM=ATAN(R(1,1)) + 300 EPSUM=EPSUM/PI + DELTA=SMLAST-EPSUM+0.5D0 + IF(DELTA.LE.0.D0) DELTA=DELTA-1.D0 + IDEL=INT(DELTA) + EPSUM=EPSUM+DBLE(IDEL) + SMLAST=EPSUM + RETURN + END + FUNCTION ESYMTP(J1,K1,J2,K2,LM,MU) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DATA CON15/.282094791773878209D0/ + Z(X)=2.D0*X+1.D0 + ESYMTP=0.D0 + XJ1=J1 + XJ2=J2 + XK1=K1 + XK2=K2 + XLM=LM + XMU=MU + E=THRJ(XJ1,XLM,XJ2,-XK1,-XMU,XK2) + IF (ABS(E).LE.1.D-8) RETURN + ESYMTP=E*PARITY3((IABS(J2-J1)+J2+J1)/2-MU-K1)* + & CON15*SQRT(SQRT(Z(XJ1)*Z(XJ2))) + RETURN + END + SUBROUTINE F02AAF(A, IA, N, R, E, IFAIL) +C +C SIMULATES NAG DIAGONALISER F02AAF WITH LAPACK CALLS +C JMH MAY 93 +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C + DIMENSION A(IA,N), R(N), E(N) + DIMENSION V(1) + DATA IV/1/ + DATA ZERO/0.D0/ +C + IT1=IXNEXT + IT2=IT1+(5*N+1)/NIPR + IT3=IT2+(N+1)/NIPR + LWREQ=8*N + LWORK=MX-IT3+1 + IF(LWORK.LT.LWREQ) THEN + WRITE(6,100) LWORK,N +100 FORMAT(' *** ERROR: ONLY',I5,' WORDS OF WORKSPACE AVAILABLE', + 1 ' IN F02AAF.'/' LAPACK ROUTINE DSYEVX NEEDS AT LEAST 8*N,', + 2 ' AND N =',I5,' ON THIS CALL.') + STOP + ENDIF +C + IXNEXT=IT3+LWREQ + NUSED=0 + CALL CHKSTR(NUSED) +C +C SAVE DIAGONAL ELEMENTS IN E +C + CALL DCOPY(N,A,IA+1,E,1) +C +C CALL LAPACK DIAGONALISER: DESTROYS LOWER TRIANGLE OF A +C + CALL DSYEVX('N','A','L',N,A,IA,DUM,DUM,IDUM,IDUM,ZERO,M,R,V,IV, + 1 X(IT3),LWORK,X(IT1),X(IT2),INFO) +C + IF (INFO .NE. 0) THEN + WRITE (6,120) INFO +120 FORMAT(' *** ERROR IN DSYEVX: INFO =',I3) + END IF +C + IFAIL=INFO + IXNEXT=IT1 +C +C RESTORE LOWER TRIANGLE FROM UNCHANGED UPPER TRIANGLE +C AND DIAGONAL FROM E +C + CALL DSYFIL('L',N,A,IA) + CALL DCOPY(N,E,1,A,IA+1) +C + RETURN + END + SUBROUTINE F02ABF(A, IA, N, R, V, IV, E, IFAIL) +C +C SIMULATES NAG DIAGONALISER F02ABF WITH LAPACK CALLS +C JMH MAY 93 +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C + DIMENSION A(IA,N), V(IV,N), R(N), E(N) + DATA ZERO/0.D0/ +C + IT1=IXNEXT + IT2=IT1+(5*N+1)/NIPR + IT3=IT2+(N+1)/NIPR + LWREQ=8*N + LWORK=MX-IT3+1 + IF(LWORK.LT.LWREQ) THEN + WRITE(6,100) LWORK,N +100 FORMAT(' *** ERROR: ONLY',I5,' WORDS OF WORKSPACE AVAILABLE', + 1 ' IN F02ABF.'/' LAPACK ROUTINE DSYEVX NEEDS AT LEAST 8*N,', + 2 ' AND N =',I5,' ON THIS CALL.') + STOP + ENDIF +C + IXNEXT=IT3+LWREQ + NUSED=0 + CALL CHKSTR(NUSED) +C +C SAVE DIAGONAL ELEMENTS IN E +C + CALL DCOPY(N,A,IA+1,E,1) +C +C CALL LAPACK DIAGONALISER: DESTROYS LOWER TRIANGLE OF A +C + CALL DSYEVX('V','A','L',N,A,IA,DUM,DUM,IDUM,IDUM,ZERO,M,R,V,IV, + 1 X(IT3),LWORK,X(IT1),X(IT2),INFO) +C + IF (INFO .NE. 0) THEN + WRITE (6,120) INFO +120 FORMAT(' *** ERROR IN DSYEVX: INFO =',I3) + END IF +C + IFAIL=INFO + IXNEXT=IT1 +C +C RESTORE LOWER TRIANGLE FROM UNCHANGED UPPER TRIANGLE +C AND DIAGONAL FROM E +C + CALL DSYFIL('L',N,A,IA) + CALL DCOPY(N,E,1,A,IA+1) +C + RETURN + END + INTEGER FUNCTION FIND(I,J,IG,NG) +C +C FUNCTION TO FIND A PARTICULAR FOURIER COMPONENT IN A LIST +C OF COMPONENTS, AND RETURN THE POSITION OF THE REQUIRED +C COMPONENT. +C + DIMENSION IG(2,NG) +C + II=I + JJ=J + CALL ORDER(II,JJ) + FIND=0 + DO 10 N=1,NG + IF(II.NE.IG(1,N) .OR. JJ.NE.IG(2,N)) GOTO 10 + FIND=N + GOTO 20 + 10 CONTINUE + 20 RETURN + END + SUBROUTINE FINDRM(W,N,RSTART,RTURN,IK,P,VL,IV,ERED,EINT,CENT, + 1 RMLMDA,DIAG,DIAG2,XK,PHASE,MXLAM,NPOTL,IRMSET,ITYPE,IPRINT) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION W(N,N),P(MXLAM),VL(1),IV(1),EINT(N),CENT(N),DIAG(N), + 1 DIAG2(N),XK(N),PHASE(N) +C +C SUBROUTINE TO FIND A SUITABLE STARTING POINT FOR INTEGRATION +C +C FIND CLASSICAL TURNING POINT OF DIAGONAL POTENTIAL +C IN LOWEST-LYING CHANNEL. +C START FROM A GUESS BASED ON THE CENTRIFUGAL POTENTIAL +C MOD 28 MAR 95 (SG) TO START AT 0.8*RMIN RATHER THAN 0.0 +C IN CASE OF FAILURE +C + RMIN=RSTART + RTURN=1.D30 + NOPEN=0 + DO 80 I=1,N + DIF=ERED-EINT(I) + IF (DIF.LT.0.D0) GOTO 80 + NOPEN=NOPEN+1 + RCENT=SQRT(CENT(I)/DIF) + RCENT=MAX(RCENT,RMIN) + RTURN=MIN(RTURN,RCENT) + 80 CONTINUE +C +C FOR SURFACE SCATTERING, OVERRIDE THE CENTRIFUGAL GUESS +C + IF (ITYPE.EQ.8) RTURN=RMIN +C + IF (NOPEN.LE.0) THEN + IF (IPRINT.GE.3) WRITE(6,*) ' *** FINDRM. NO OPEN CHANNELS' + GOTO 300 + ENDIF +C + ITRY=0 + 90 RSTART=RTURN + IF (ITRY.GT.25) GOTO 140 + CALL WAVMAT(W,N,RSTART,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, + 1 MXLAM,NPOTL) +C +C FIND LOWEST CHANNEL +C + IK=1 + V1=DIAG(1) + DO 100 I=1,N + IF (DIAG(I).GE.V1) GO TO 100 + IK=I + V1=DIAG(I) + 100 CONTINUE +C + RTURN=0.999D0*RSTART + DO 120 II=1,100 + CALL WAVMAT(W,N,RTURN,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG2, + 1 MXLAM,NPOTL) +C +C CHECK THAT CHANNEL IK IS STILL LOWEST, AND CALCULATE ALL +C THE DERIVATIVES FOR USE LATER +C + V2=DIAG2(IK) + DO 110 I=1,N + XK(I)=(DIAG2(I)-DIAG(I))/(RTURN-RSTART) + DIAG(I)=DIAG2(I) + IF (DIAG(I).LT.V2) THEN + ITRY=ITRY+1 + GOTO 90 + ENDIF + 110 CONTINUE + DV1=XK(IK) +C + IF (IPRINT.GE.8) WRITE(6,602) RTURN,V2 + 602 FORMAT(' FINDRM: AT R =',F8.4,' SMALLEST V-E IS',F11.2) +C +C THERE MIGHT BE A WELL BEHIND THE BARRIER MAXIMUM. +C PROVIDED IT IS ABOVE THE SCATTERING ENERGY, JUMP OVER IT +C AND TRY AGAIN. ONLY DO THIS ONCE, THOUGH. +C + IF (DV1.GE.0.D0) THEN + IF (V2.GT.0.D0) THEN + ITRY=ITRY+10 + IF (ITRY.LT.20) THEN + RTURN=2.D0*RTURN + GOTO 90 + ELSE + GOTO 140 + ENDIF + ELSE + ITRY=ITRY+5 + RTURN=0.9D0*RTURN + GOTO 90 + ENDIF + ENDIF + RSTART=RTURN + V1=V2 + DR=-V1/DV1 + IF (DR.LT.-0.3D0*RTURN .AND. ITYPE.NE.8) DR=-0.3D0*RTURN + RTURN=RTURN+DR + IF (ITRY.GT.25 .OR. DR.GT.1.D3) GO TO 140 + IF (RTURN.LE.0.D0 .AND. ITYPE.NE.8) GO TO 140 + IF (ABS(DR/RTURN).LE.1.D-3) GO TO 160 + 120 CONTINUE +C +C ARRIVE HERE IF DR BECOMES HUGE, RTURN BECOMES NEGATIVE, +C OR THERE IS NO CONVERGENCE IN 100 NEWTON-RAPHSON ITERATIONS. +C IF THIS HAPPENS, JUST USE THE INPUT VALUE OF RMIN +C + 140 IF (IPRINT.GE.3) WRITE(6,*) ' *** FINDRM. ', + 1 'UNABLE TO FIND CLASSICAL TURNING POINT' + GOTO 300 +C +C ARRIVE HERE IF WE HAVE CONVERGED ON A CLASSICAL TURNING POINT +C DIAG ARRAY CONTAINS DIAGONAL ELEMENTS +C + 160 IF (IPRINT.GE.3) WRITE(6,603) RTURN + 603 FORMAT(' INNER CLASSICAL TURNING POINT AT R =',F8.4) +C +C SPECIAL CASE: CALLED TO FIND RTURN ONLY +C + IF (IRMSET.LE.0) THEN + RSTART=RMIN + RETURN + ENDIF +C +C FIND NEW RSTART BY INTEGRATING PHASE INTEGRALS INWARDS. +C WE WANT RSTART SUCH THAT +C INT(RSTART,RTURN) SQRT(E-V) DR = 2.303 * IRMSET +C TRY TO DO IT IN NSTEP ROUGHLY EQUAL STEPS +C + NSTEP=3+IRMSET/3 +C + TARGET=2.303D0*DBLE(IRMSET) + DR=1.5D0*TARGET/SQRT(ABS(XK(IK)))/DBLE(NSTEP) +C + DO 210 I=1,N + PHASE(I)=0.D0 + XK(I)=SQRT(ABS(DIAG(I))) + 210 CONTINUE +C + 220 CONTINUE +C + DO 240 ISTEP=1,NSTEP + RNEXT=RSTART-DR + IF (RNEXT.LT.0.D0 .AND. ITYPE.NE.8) THEN + RSTART=0.8*RMIN + IF (IPRINT.GE.1) THEN + WRITE(6,*) ' *** FINDRM. REACHED ORIGIN ', + 1 'WHILE ACCUMULATING PHASE INTEGRAL. CHECK POTENTIAL' + WRITE(6,*) ' PROPAGATION WILL START AT 0.8*RMIN' + ENDIF + RETURN + ENDIF +C + CALL WAVMAT(W,N,RNEXT,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, + 1 MXLAM,NPOTL) + DRNEXT=0.D0 + DO 230 I=1,N + IF (DIAG(I).LE.0.D0) THEN + IF (IPRINT.GE.3) + 1 WRITE(6,*) ' *** FINDRM. INNER CLASSICALLY ALLOWED REGION ', + 1 'ENCOUNTERED WHILE INTEGRATING INWARDS FROM TURNING POINT.' + GOTO 260 + ENDIF + V1=SQRT(DIAG(I)) + V2=0.5D0*(V1+XK(I)) + PHASE(I)=PHASE(I)+DR*V2 + DRNEXT=MAX(DRNEXT,(TARGET-PHASE(I))/V1) + XK(I)=V1 + 230 CONTINUE +C + RSTART=RNEXT + IF (ISTEP.LT.NSTEP) DR=DRNEXT/DBLE(NSTEP-ISTEP) +C + IF (IPRINT.GE.8) WRITE(6,604) ISTEP,RNEXT,DR,DIAG(IK) + 604 FORMAT(' FINDRM: STEP',I3,' AT R =',2F8.4,F11.2) +C + IF (DRNEXT.LE.0.D0) GOTO 250 +C +C IF THE STEP SIZE SEEMS EXCESSIVE, TRY ACCUMULATING THE +C PHASE INTEGRAL MORE CAUTIOUSLY +C + IF (ISTEP.LT.NSTEP .AND. ITYPE.NE.8 + 1 .AND. DR.GT.0.5D0*RSTART .AND. DR.GT.0.5D0*RMIN) THEN + DR=0.02D0*RSTART + GOTO 220 + ENDIF +C + 240 CONTINUE +C + 250 IF (IPRINT.GE.3) WRITE(6,606) RSTART + 606 FORMAT(' RADIAL INTEGRATION WILL START AT R =',F8.4) + RETURN +C +C ARRIVE HERE IF THE INWARDS SEARCH ENTERED A CLASSICALLY ALLOWED +C REGION. TRY TO FIND A BETTER STARTING POINT AND LOOK FOR THE +C INNER TURNING POINT +C + 260 DR=0.1D0*RNEXT + RTURN=RNEXT-DR + DO 290 II=1,9 + CALL WAVMAT(W,N,RTURN,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, + 1 MXLAM,NPOTL) + DO 270 I=1,N + IF (DIAG(I).LE.0.D0) GOTO 280 + 270 CONTINUE + ITRY=ITRY+10 + GOTO 90 + 280 RTURN=RTURN-DR + 290 CONTINUE + IF (IPRINT.GE.1) THEN + WRITE(6,*) ' *** FINDRM. UNABLE TO FIND', + 1 ' INNER CLASSICAL TURNING POINT. CHECK POTENTIAL' + WRITE(6,*) ' PROPAGATION WILL START AT 0.8*RMIN' + ENDIF + RSTART=0.8*RMIN + RETURN +C + 300 RSTART=RMIN + RTURN=2.D0*RMIN + IF (IPRINT.GE.3) WRITE(6,608) + 608 FORMAT(14X,'RSTART SET TO RMIN'/14X,'RTURN SET TO 2*RMIN') + RETURN +C + END + SUBROUTINE FINDRX(ENERGY,EINT,CENT,NNRG,N,CINT,RMAX,RSTOP, + 1 NOPMAX,IRXSET,IPRINT) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C SUBROUTINE TO SCAN INPUT ENERGIES AND THRESHOLDS TO DETERMINE +C A SAFE RMAX WHICH IS OUTSIDE THE CENTRIFUGAL BARRIER FOR +C ALL COMBINATIONS. ALSO FIND THE LARGEST VALUE OF NOPEN +C TO SAFEGUARD AGAINST SHRINKING THE BASIS SET TOO FAR. +C + DIMENSION ENERGY(NNRG),EINT(N),CENT(N) +C + NOPMAX=0 + RSTOP=RMAX + DO 200 J=1,NNRG + NOPEN=0 + ERED=ENERGY(J)*CINT + DO 100 I=1,N + DIF=ERED-EINT(I) + IF(DIF.LT.0.D0) GOTO 100 + NOPEN=NOPEN+1 + IF(IRXSET.LE.0) GOTO 100 + RCENT=SQRT(CENT(I)/DIF) + RSTOP=MAX(RSTOP,RCENT) + 100 CONTINUE + 200 NOPMAX=MAX0(NOPMAX,NOPEN) + IF(RSTOP.GT.RMAX .AND. IPRINT.GE.3) WRITE(6,601) RSTOP + 601 FORMAT('0 RMAX INCREASED TO',F7.2,' FOR THIS PARITY CASE', + 1 ' TO ENSURE THAT OPEN CHANNEL MATCHING'/' OCCURS BEYOND', + 2 ' THE CENTRIFUGAL BARRIER FOR ALL ENERGIES') + RETURN + END + FUNCTION FSYMTP(J1,K1,L1,J2,K2,L2,JT,LAM,MU) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C CALCULATES MATRIX ELEMENT FOR SYMMETRIC TOP FUNCTIONS +C (J1 K1 L1, JTOT / Y(LAM,MU) / J2 K2 L2, JTOT). +C USES SUBROUTINES - +C THRJ(XJ1,XJ2,XJ3,XM1,XM2,XM3) +C THREEJ(J1,J2,J3) WHICH IS FOR M1=M2=M3=0 +C SIXJ(J1,L1,J2,L2,JTOT,LAM) +C + DATA PI/3.14159265358979289D0/ +C STATEMENT FUNCTION DEFINITION . . . + Z(Y) = 2.D0 * Y + 1.D0 +C + IF (K1-K2+MU .NE. 0) GO TO 9000 + F=THREEJ(L1,L2,LAM) + IF (F.EQ.0.D0) GO TO 9000 + XJ1=J1 + XJ2=J2 + XK1=K1 + XK2= - K2 + XL1=L1 + XL2=L2 + XLAM=LAM + XMU=MU + F=F * THRJ(XJ1,XJ2,XLAM,XK1,XK2,XMU) + IF (F.EQ.0.D0) GO TO 9000 + F=F * SIXJ(J1,L1,J2,L2,JT,LAM) + IF (F.EQ.0.D0) GO TO 9000 + PH=PARITY3(J1+J2+K2-JT) + F=F*PH*SQRT(Z(XJ1)*Z(XJ2)*Z(XL1)*Z(XL2)*Z(XLAM)/(4.D0*PI)) + FSYMTP=F + RETURN + 9000 FSYMTP=0.D0 + RETURN + END + SUBROUTINE GASLEG(N,Z,A) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C *** ROUTINE TO GENERATE GAUSS-LEGENDRE POINTS/WEIGHTS +C *** TAKEN FROM AD VAN DER AVOIRD'S N2-N2 CODE (SG 11/7/91) +C *** NEEDS FUNCTION ZBES + DIMENSION P(301),PD(301),Z(1),A(1) + DATA PI/3.14159 26535 89793 D0/ + IF (N.LE.300) GO TO 20 + WRITE (6,10) + 10 FORMAT (/10X,31H***** GASLEG N TOO LARGE *****/) + STOP + 20 NN=N+1 + IFIN=0 + IODD=0 + C=2.0D0/PI + C=1.0D0-(C*C) + IF (MOD(N,2).EQ.0) GO TO 30 + NKNT=(N-1)/2 + IODD=1 + GO TO 40 + 30 NKNT=N/2 + 40 K=1 + CHA=0.0D0 + CHB=0.0D0 + P(1)=1.0D0 + DN=N+0.50D0 + DN2=DN*DN + DEN=SQRT(DN2+(C/4.0D0)) + 50 BES=ZBES(K) + X=COS(BES/DEN) + PDX=1.0D0/(1.0D0-X*X) + 60 CONTINUE + P(2)=X + DO 70 I=3,NN + IN=I-1 + IM=I-2 + P(I)=((2.0D0*IN-1.0D0)*X*P(IN)-IM*P(IM))/IN + PD(I)=IN*PDX*(P(IN)-X*P(I)) + 70 CONTINUE + IF (IFIN.EQ.1) GO TO 100 + IF (ABS(P(NN)).LT.1.0D-12) GO TO 80 + X=X-(P(NN)/PD(NN)) + PDX=1.0D0/(1.0D0-X*X) + GO TO 60 + 80 Z(K)=X + TA=N*P(N) + TA=TA*TA + A(K)=(2.0D0*(1.0D0-X*X))/TA + CHA=CHA+2.0D0*A(K) + Z2=Z(K)*Z(K) + CHB=CHB+2.0D0*A(K)*Z2 + IF (K.EQ.NKNT) GO TO 90 + K=K+1 + GO TO 50 + 90 CONTINUE + IF (IODD.EQ.0) GO TO 110 + X=0.0D0 + K=NKNT+1 + Z(K)=X + IFIN=1 + GO TO 60 + 100 TA=N*P(N) + TA=TA*TA + A(K)=2.0D0/TA + CHA=CHA+A(K) + 110 CONTINUE + RETURN + END + SUBROUTINE GAUSHP(NN,X,A) +C CALCULATES THE ZEROS, X(I), AND WEIGHTS, A(I), I=1,NN, FOR +C GAUSS-HERMITE QUADRATURE. +C Approximates the integral from -infinity to infinity f(x)*exp(-x**2) +C by the sum(i=1,nn) w(i)*f(x(i)). +C ADAPTED BY S. GREEN FROM STROUD AND SECREST GAUSSIAN QUADRATURE FORMULAS. +C VERSION OF 18 APRIL 94; FIXED NN=1 BUG 10 MAR 95 (SG) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + PARAMETER (MXIT=15) + DIMENSION X(NN),A(NN) + DATA EPS/1.D-15/ +C + GAM(Y)=(((((((.035868343D0*Y-.193527818D0)*Y+.482199394D0)*Y- + 1 .756704078D0)*Y+.918206857D0)*Y-.897056937D0)*Y+ + 2 .988205891D0)*Y-.577191652D0)*Y+1.D0 +C + IF (NN.LE.0) THEN + WRITE(6,*) ' *** GAUSHP CALLED FOR ILLEGAL NPT=',NN + STOP + ELSEIF (NN.EQ.1) THEN + WRITE(6,*) ' *** GAUSHP. WARNING, SINGLE POINT REQUESTED.' + X(1)=0.D0 + A(1)=SQRT(ACOS(-1.D0)) + RETURN + ELSE + FN=NN + N1=NN-1 + N2=(NN+1)/2 +C COMPUTE GAMMA FN BY HASTINGS APPROX; 0.LE.X.LE.70. + Z=FN + IF (Z.LE.0.D0 .OR. Z.GE.7.D1) THEN + WRITE(6,600) Z + 600 FORMAT(' *** GAUSHP. CANNOT GET GAMMA FUNCTION FOR',F10.2) + STOP + ENDIF + IF (Z.EQ.1.D0) THEN + GAMMA=1.D0 + GO TO 20 + ELSEIF (Z.LT.1.D0) THEN + GAMMA=GAM(Z)/Z + GO TO 20 + ELSE + ZA=1.D0 + 10 Z=Z-1.D0 + IF (Z-1.D0) 13,11,12 + 11 GAMMA=ZA + GO TO 20 + 12 ZA=ZA*Z + GO TO 10 + 13 GAMMA=ZA*GAM(Z) + GO TO 20 + ENDIF + 20 CC=1.7724538509D0*GAMMA*(2.D0**(-N1)) + S=(2.D0*FN+1.D0)**(1.D0/6.D0) + DO 100 I=1,N2 + IF (I.EQ.1) THEN +C LARGEST ZERO + XT=S**3-1.85575D0/S + GO TO 50 + ELSEIF (I.EQ.2) THEN +C SECOND ZERO + XT=XT-1.14D0*FN**.426D0/XT + GO TO 50 + ELSEIF (I.EQ.3) THEN +C THIRD ZERO + XT=1.86D0*XT-0.86D0*X(1) + GO TO 50 + ELSEIF (I.EQ.4) THEN +C FOURTH ZERO + XT=1.91D0*XT-0.91D0*X(2) + GO TO 50 + ELSE +C ALL HIGHER ZERO'S + XT=2.D0*XT-X(I-2) + ENDIF +C +C IMPROVE THE APPROXIMATE ROOT XT AND OBTAIN +C DPN = DERIVATIVE OF H(N) AT XT; PN1 = VALUE OF H(N-1) AT XT + 50 IT=0 + 60 IT=IT+1 + IF (IT.GT.MXIT) THEN + WRITE(6,*) ' *** GAUSHP FAILED TO CONVERGE. ITERATIONS =' + 1 ,MXIT + STOP + ENDIF + CALL HRECUR(P,DP,PN1,XT,NN) + D=P/DP + XT=XT-D + IF (ABS(D).GT.EPS) GO TO 60 + DPN=DP + X(I)=XT + A(I)=CC/(DPN*PN1) + NI=NN-I+1 + X(NI)=-XT + 100 A(NI)=A(I) + ENDIF + RETURN + END + SUBROUTINE GAUSSP(A,B,NPT,XPT,WHT) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION XPT(NPT),WHT(NPT) +C +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +C THIS ROUTINE SETS UP ABSCISSAE AND WEIGHTS FOR NPT-POINT * +C GAUSS-LEGENDRE INTEGRATION IN THE INTERVAL (A,B). * +C * +C ON RETURN, THE FUNCTION TO BE INTEGRATED SHOULD BE EVALUATED * +C AT THE POINTS XPT(I). INTEGRAL = SUM(I=1,NPT) F(XPT(I))*WHT(I)* +C * +C THIS VERSION (SG 11/7/91) CALCULATES POINTS/WEIGHTS FROM * +C GASLEG/ZBES CODE OF AD VAN DER AVOIRD * +C DOES ANY NUMBER OF PTS FROM 1 TO MXPT, WHERE LIMIT IS FROM * +C DIMENSION STATEMENTS IN GASLEG (P,PD AT LEAST (MXPT+1) ) * +C AND HERE W,X DIMENSIONED AT LEAST ((MXPT+1)/2) * +C * +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +C + DIMENSION X(128),W(128) + DATA MXPT/256/ +C + T1=(B-A)/2.D0 + T2=(B+A)/2 + IF (NPT-1) 9999,9998,9997 + 9997 IF (NPT.LE.MXPT) GO TO 3100 + WRITE(6,601) NPT,MXPT + 601 FORMAT('0 * * * WARNING. GAUSS-LEGENDRE NPT =',I6,' REDUCED TO', + 1 I4) + NPT=MXPT + 3100 CALL GASLEG(NPT,X,W) + N2=(NPT+1)/2 + I1=1 + I2=NPT + IC=1 + DO 2000 I=1,N2 + XPT(I1)=-X(IC)*T1+T2 + XPT(I2)=X(IC)*T1+T2 + WHT(I1)=W(IC)*T1 + WHT(I2)=WHT(I1) + I1=I1+1 + I2=I2-1 + 2000 IC=IC+1 +C N.B FOR NPT ODD, THE LAST (I.E. MIDDLE) TERM IS EVALUATED TWICE. + RETURN + 9999 WRITE(6,610) NPT + 610 FORMAT('0 * * * WARNING. GAUSS-LEGENDRE REQUESTED WITH NPT =',I6) +C REPLACE WITH SINGLE-POINT AT (A+B)/2 * (B-A) + NPT=1 + 9998 XPT(1)=T2 + WHT(1)=2.D0*T1 + RETURN + END + SUBROUTINE GCLOCK(XTIME) + DOUBLE PRECISION XTIME + REAL TIME,TTIME + DIMENSION TTIME(2) +C +C THIS ROUTINE IS MACHINE-DEPENDENT. +C IT SHOULD RETURN THE ELAPSED CPU TIME IN UNITS OF SECONDS. +C ONLY DIFFERENCES ARE USED, SO IT NEED NOT BE AN ABSOLUTE VALUE. +C +C DUMMY RESULT FOR VANILLA DISTRIBUTION + XTIME=0.D0 +C +C CODE BELOW CALLS THE BSD UNIX TIMING ROUTINE. +C A C VERSION OF etime FOR MOST OTHER UNIX SYSTEMS IS AVAILABLE FROM JMH. +C TIME=etime(TTIME) +C XTIME=DBLE(TIME) +C +C CODE BELOW IS THE GISS ROUTINE +C CALL CLOCKS(ITIME) +C XTIME=-ITIME +C XTIME=XTIME*1.D-2 + RETURN + END + SUBROUTINE GDATE(CDATE) +C +C THESE ROUTINES ARE MACHINE-DEPENDENT, AND MUST BE SIMULATED. +C THEY SHOULD RETURN STRINGS CONTAINING THE CURRENT DATE & TIME. +C + CHARACTER CDATE*11, CTIME*9 + CDATE='UNKNOWN ' + RETURN + ENTRY GTIME(CTIME) + CTIME='UNKNOWN ' + RETURN + END + SUBROUTINE GET102(MXLVL,NLEVEL,JLEVEL,ELEVEL) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION JLEVEL(2,MXLVL),ELEVEL(MXLVL) + WRITE(6,699) + 699 FORMAT('0 GET102. DUMMY ROUTINE CALLED. TERMINAL ERROR.') + STOP + END + FUNCTION GSYMTP(J1,K1,J2,K2,MVAL,LM,MU) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DATA Z0/0.D0/, PIFCT/.282094791773878209D0/ +C STATEMENT FUNCTION . . . + Z(X)=2.D0*X+1.D0 +C + XJ1=J1 + XK1=K1 + XJ2=J2 + XK2=K2 + XM=MVAL + XLM=LM + XMU=MU + GSYMTP=0.D0 + F=THRJ(XJ1,XLM,XJ2,XK1,XMU,-XK2) + IF (ABS(F) .LE. 1.D-8) RETURN + F=F*THRJ(XJ1,XLM,XJ2,-XM,Z0,XM) + IF (ABS(F) .LE. 1.D-8) RETURN + GSYMTP=F*PIFCT*SQRT(Z(XJ1)*Z(XJ2)*Z(XLM))*PARITY3(K1+MVAL) + RETURN + END + SUBROUTINE HEADER(W,WX,N,NSQ,P,VL,IV,EINT,CENT,DIAG,MXLAM,NPOTL, + 1 ICODE,ISAV,EFIRST) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C ROUTINE TO WRITE/CHECK A HEADER LABEL ON UNIT ISCRU FOR USE +C WITH THE OPTION TO SAVE TRANSFORMATION MATRICES FOR A SUBSEQUENT +C RUN. THE LABEL CONSISTS OF ALL INTEGRATION TOLERANCES AND +C A SAMPLE POTENTIAL MATRIX. +C +C THE VARIOUS FLAGS ARE USED AS FOLLOWS: +C ICODE=1, ISAV=1: FIRST ENERGY, WRITE HEADER +C ICODE=1, ISAV=-1: FIRST ENERGY, CHECK HEADER +C ICODE=2: SUBSEQUENT ENERGY, SKIP HEADER +C +C + DIMENSION W(NSQ),WX(NSQ),P(MXLAM),VL(1),IV(1),EINT(N),CENT(N), + 1 DIAG(N),PAR(13),PARX(13) +C COMMON BLOCK FROM DRIVER AND RMTPRP + COMMON/DRIVE/STEST,STEPS,STAB,CONV,RMIN,RMAX,XEPS,DR, + 1 DRMAX,RMID,TOLHI,RTURN, + 2 VTOL,ESHIFT,ERED,RMLMDA,NOPEN,JKEEP,ISCRU,MAXSTP + EQUIVALENCE(PAR(1),STEST) +C + IF(ISCRU.EQ.0) RETURN + REWIND ISCRU + IF(ISAV.EQ.0) RETURN + IF(ICODE.EQ.1) GO TO 40 +C +C SUBSEQUENT ENERGY CALC. - SKIP OVER ANY HEADER +C + READ(ISCRU) + READ(ISCRU) + RETURN +C +40 IF(ISAV.EQ.-1) GO TO 60 +C +C WRITE OUT A HEADER +C + RX=2.D0*RMIN + CALL WAVMAT(W,N,RX,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM, + 1 NPOTL) + WRITE(ISCRU) N,EFIRST,RX,PAR + WRITE(ISCRU) W + RETURN +C +C READ AND VERIFY HEADER. SET NOPEN=-1 AS A FLAG THAT NO ACTUAL +C SCATTERING CALCULATION IS TO BE DONE FOR THIS ENERGY. +C SET ICODE=2 SO THAT A "SUBSEQUENT ENERGY" CALCULATION IS DONE +C +60 READ(ISCRU) NX,EFIRST,RX,PARX + IF(N.NE.NX) GO TO 999 + DO 62 I=1,13 + IF(PAR(I).NE.PARX(I)) GO TO 999 +62 CONTINUE + CALL WAVMAT(W,N,RX,P,VL,IV,EFIRST,EINT,CENT,RMLMDA,DIAG,MXLAM, + 1 NPOTL) + READ(ISCRU) WX + DO 64 I=1,NSQ + IF(W(I).NE.WX(I)) GO TO 998 +64 CONTINUE + ICODE=2 + WRITE(6,603) ISCRU +603 FORMAT('0 HEADER LABEL ON UNIT',I3,' SUCCESSFULLY VERIFIED.') + RETURN +C +C HEADER IS WRONG - RUN TERMINATED +C +998 WRITE(6,600) ISCRU +600 FORMAT('0****** ERROR - HEADER ON UNIT',I3,' DOES NOT AGREE', + 1 ' WITH DATA FOR CURRENT RUN'/) + WRITE(6,601) (W(I),WX(I),I=1,NSQ) +601 FORMAT(2D24.15,10X,2D24.15) +999 WRITE(6,600) ISCRU + WRITE(6,602) N,NX,(PAR(I),PARX(I),I=1,13) +602 FORMAT(2I8/(2D24.15)) + STOP + END + SUBROUTINE HERM(H,N,X) +C +C SUBROUTINE TO GENERATE HERMITE POLYNOMIALS +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION H(N) + P0=1.0D0 + H(1)=P0 + IF(N.LE.1) RETURN + X2=X+X + P1=X2 + H(2)=P1 + IF(N.LE.2) RETURN + DO 100 K=3,N + TEMP=X2*P1 - DBLE(K+K-4)*P0 + P0=P1 + P1=TEMP + H(K)=P1 + 100 CONTINUE + RETURN + END + SUBROUTINE HRECUR(PN,DPN,PN1,X,NN) +C SG: ADAPTED FROM STROUD AND SECREST, GAUSSIAN QUADRATURE FORMULAS GREEN. + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + P1=1.D0 + P=X + DP1=0.D0 + DP=1.D0 + DO 1 J=2,NN + FJ=J + FJ2=(FJ-1.D0)/2.D0 + Q=X*P-FJ2*P1 + DQ=X*DP+P-FJ2*DP1 + P1=P + P=Q + DP1=DP + 1 DP=DQ + PN=P + DPN=DP + PN1=P1 + RETURN + END + SUBROUTINE IDPART(ITYPE,IDENT,SPNUC,WT) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION WT(2) +C +C THIS ROUTINE PROCESSES INPUT FOR IDENTICAL TARGET-PROJECTILE. +C IDENT.NE.0 IMPLIES TARGET AND PROJECTILE ARE IDENTICAL. +C OTHERWISE (IDENT.EQ.0) IEXCH=0 IN ALL CASES AND NO PROCESSING +C WITH IEXCH OR WT WILL OCCUR. +C + CHARACTER*8 NAME(2) + DATA NAME/' BOSE ',' FERMI '/ +C + IF (IDENT.EQ.0) RETURN + WRITE(6,600) + 600 FORMAT('0 IDENT PARAMETER SPECIFIES THAT TARGET AND PROJECTILE ARE + 1 IDENTICAL. PROPERLY SYMMETRIZED FUNCTIONS WILL BE CONSTRUCTED.') + IF (ITYPE.EQ.3.OR.ITYPE.EQ.13.OR.ITYPE.EQ.23) GO TO 1000 + WRITE(6,601) ITYPE + 601 FORMAT('0 * * * ERROR. FOR ITYPE =',I4,' IDENT PROCESSING NOT SUP + 1PORTED. REQUEST CANCELLED.') + IDENT=0 + RETURN + 1000 SPNUC=ABS(SPNUC) + IF (WT(1).EQ.0.D0 .AND. WT(2).EQ.0.D0) GO TO 2000 + WRITE(6,603) WT + 603 FORMAT(' STATISTICAL WEIGHTS SPECIFIED AS WT IN &BASIS DATA. SPN + 1UC IGNORED.'/10X,'ANTI-SYMMETRIC, WT(1) =',F7.4,', SYMMETRIC, WT( + 22) =',F7.4) + RETURN + 2000 IST=INT(2.D0*SPNUC+0.0001D0) + IST=IST-2*(IST/2) +C IST=0 FOR BOSE STATISTICS, IST=1 FOR FERMI STATISTICS. + DN=2.D0*SPNUC+1.D0 + WT(2-IST)=(SPNUC+1.D0)/DN + WT(IST+1)=SPNUC/DN + WRITE(6,602) SPNUC,NAME(IST+1),WT + 602 FORMAT(' FOR NUCLEAR SPIN =', F6.2,',',A8,' STATISTICAL WEIGHTS A + 1RE'/10X,'ANTI-SYMMETRIC, WT(1) =',F7.4,', SYMMETRIC, WT(2) =', + 2 F7.4) + RETURN + END + SUBROUTINE IOSBIN(NVC,ITYPX,ATAU,MX,IASYMU,IPHIFX,IOSNG) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE +C +C *** MODIFIED FEB 92 TO CHANGE ITYPE=2 TO USE IV() INDEXING +C *** MODIFIED MAY 92 TO HANDLE ITYPE=103 (SG) *** +C *** MODIFIED JAN/FEB 92 TO GENERALIZE ITYPE=2 HANDLING +C *** MODIFIED FEB 88 TO CORRECT 'IHOMO' HANDLING OF ITYPE=5,6 CASES +C WHERE POTENTIAL IS SYMMETRIC ABOUT THETA=PI/2 +C *** AUG 86 ADD LM,LMAX ARGUMENTS TO IXQLF +C *** UPDATED APR 86 TO MERGE BASIN-IOSBIN PROCESSING +C +C THIS IS IOS 'BASIS' ROUTINE FOR COMBINED MOLSCAT/IOS APR 86 +C MODIFICATIONS MAY 1978 FOR ITYPE=5. +C MODIFICATIONS SEPT 1985 FOR ITYPE=6, +C INCLUDING ADDITION OF MMAX TO &INPUT. +C +C-----ENTRY IOSBIN READS &BASIS AND SETS UP BASIS DATA. +C PARAMETERS ARE NVC (NO. VIB. CHANNELS), ITYPX RETURNS ROTOR TYPE +C AND ATAU(MX) WHICH WILL HOLD ROTOR COEFF. FOR ITYPE=6 +C + DIMENSION ATAU(MX) +C +C-----ENTRY IOSBGP GETS LAM(MXLAM) INFORMATION FROM &POTL. +C CAN THEN CHOOSE NGPT, LMAX, MMAX, AND SET UP GAUSS PTS/WTS +C SPECIFICATIONS FOR ENTRY IOSBGP . . . + DIMENSION LAM(MXLAM) + LOGICAL ODD +C +C-----ENTRY IOSB1, CALLED AFTER STORAGE IS ALLOCATED, SETS UP PWGHT, VLI +C ALSO IXQL AND LM. +C SPECIFICATIONS . . . + DIMENSION PWGHT(NGPT,LMAX), VLI(NGPT,MXXXXL) + DIMENSION IXQL(NIXQL,NQL),LM(3,LMAX) +C BELOW (TEMPORARY) TO CONTROL FLOW OF ALTERNATE ITYPE=3 CODE + LOGICAL LNEW +C +C-----ENTRY IOSB2 IS CALLED JUST BEFORE INTEGRATOR. SETS UP VL, ETC. +C SPECIFICATIONS FOR ENTRY IOSB2 . . . + DIMENSION CENT(NVC),EINT(NVC),WVEC(NVC),VL(2),IVIX(2) + DIMENSION LORB(NVC),JJJ(NVC),NB(NVC) +C COMMON TO PASS ANGLES TO VRTP FOR "UNEXPANDED" (MXLAM=0) POTL CASE +C N.B. 3RD ANGLE FOR ITYPE=3. IH0,IC0 TO SET IHOMO,ICNSYM IN VRTP +C FACTOR IS 1./(VALUE OF LOWEST ANGULAR TERM) - DEPENDS ON ITYPE + COMMON/ANGLES/COSANG(7),FACTOR,IH0,IC0,IH1,IC1 + LOGICAL LVRTP +C +C-----ENTRY IXQLF RETURNS INDEX IN IXQL OF AN INPUT L,M1,M2,ICDE SYM. +C +C +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +C +C TO CONTROL DEBUGGING OUTPUT OF COUPLING MATRIX +C LDEBUG=.TRUE. CAN GIVE QUITE A BIT OF OUTPUT ! + LOGICAL LDEBUG +C +C SPECIFICATIONS FOR MOLSCAT(&BASIS) COMPATIBILITY. . . + DIMENSION ROTI(12),ALPHAE(2),BE(2),DE(2),A(2),B(2),C(2),WE(2), + 1 WEXE(2),WT(2),ELEVEL(1000) + INTEGER JMIN,JMAX,NLEVEL,JLEVEL(4000),J1MIN,J1MAX,J2MIN,J2MAX, + 1 IDENT,JSTEP,J1STEP,J2STEP,ISYM(10),ISYM2(10) + EQUIVALENCE (ROTI(1),BE(1),A(1)), (ROTI(3),ALPHAE(1),B(1)), + 1 (ROTI(5),DE(1),C(1)),(JMIN,J1MIN),(JMAX,J1MAX), + 2 (JSTEP,J1STEP), (ROTI(7),WE(1)),(ROTI(9),WEXE(1)) +C + COMMON /CMBASE/ ROTI,ELEVEL,EMAX,WT,SPNUC,NLEVEL,JLEVEL, + 1 JMIN,JMAX,JSTEP,ISYM,J2MIN,J2MAX,J2STEP,ISYM2,JHALF,IDENT, + 2 MXJL,MXEL +C +C INTERNAL VERSION OF JLEVEL,ELEVEL IS ALSO USED; CF IOSOUT + DIMENSION LEVV(4000),EV(1000) +C +C COMMON BLOCK TO COMMUNICATE WITH IOSOUT . . . + COMMON /IOUTCM/ MAX,LEVV +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MXXX,IXNEXT,NIPR,IVLFL,X(1) +C +C IOS GAUSS POINT CONTROL + DIMENSION IOSNGP(3),IOSNG(3) +C +C ****************************************************************** +C ** PROGRAM LIMITATION ** +C ** DIMENSIONS FOR GAUSS POINTS ** +C ** ------- ---------- ** +C ** COULD USE /MEMORY/ FOR DYNAMIC STORAGE, BUT BELOW SHOULD ** +C ** SUFFICE FOR MOST FEASIBLE CALCULATIONS. ** +C ****************************************************************** + PARAMETER(MXGPT=400) + DIMENSION COSA(MXGPT),GWT(MXGPT) +C FOR ITYPE=3 TO HOLD PLM(LI,M,) AND COS(M*PHI) -- LNEW=.TRUE. CODE + DIMENSION PL1(MXGPT),PL2(MXGPT),COSM(MXGPT) +C +C AND EQUIVALENT INTERNAL ARRAYS + DATA NVCMX/1000/ + DATA IZ/0/ + DATA LNEW/.TRUE./,LDEBUG/.FALSE./ +C +C STATEMENT FUNCTION USED IN DETERMINING ITYPE=5,6 IHOMO SYMMETRY + ODD(I,J)=(I-J)-2*((I-J)/2) .NE. 0 +C +C +C SPECIFICATIONS FOR LEGENDRE STATEMENT FUNCTION . . . + XLEG(I,TH)=SQRT(2.D0/DBLE(2*I+1))*PLM(I,0,TH) +C N.B. PLM(L,M,COSTH) RETURNS A **NORMALIZED** ASSOC. LEG. POLY. +C +C NB. THE FOLLOWING VARIABLES ARE USED AS LIMITS (SOME ITYPE=5 ONLY) +C MAX=HIGHEST J IN BASIS / MXK=HIGHEST K (SYM. TOP) IN BASIS. +C LMBDMX=HIGHEST LAMBDA IN POTL / MUMX=HIGHEST MU IN POTL +C LMMAX=HIGHEST 'L' IN SLLR,SLLI,QLT / MUMAX=HIGHEST 'M' +C +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +C + PI=ACOS(-1.D0) + WRITE(6,666) + 666 FORMAT('0 PROCESSED BY IOSBIN ROUTINE (FEB 94).') +C +C SET LOCAL (AND HENCE KEPT) VALUES FROM ARGUMENTS + DO 1107 I=1,3 + 1107 IOSNGP(I)=IOSNG(I) + IPHIFL=IPHIFX +C INITIALIZE SIZE OF ATAU TO ZERO. + MXA=MX + MX=0 +C SET DEFAULT IH0,IC0, IH1, IC1 WHICH MAY BE CHANGED IN VRTP + IH0=0 + IC0=0 + IH1=0 + IC1=0 +C + WRITE(6,620) ITYPX + 620 FORMAT('0 INPUT ITYPE =',I4) +C + ITYP=ITYPX-10*(ITYPX/10) + ITYPX=100+ITYP +C SET IVLFL TO ZERO FOR MOST CASES; EXCEPTION IS ITYPE=102 (FEB 94) + IVLFL=0 + IF (ITYP.EQ.1) GO TO 1000 + IF (ITYP.EQ.2) GO TO 2000 + IF (ITYP.EQ.3) GO TO 3000 + IF (ITYP.EQ.5) GO TO 5000 + IF (ITYP.EQ.6) GO TO 6000 + WRITE(6,699) ITYP + 699 FORMAT('0 * * * ERROR. MOD(ITYPE,10) =',I3,' NOT SUPPORTED.') + STOP +C + 1000 NVC=1 + ASSIGN 6100 TO IGOTP + EV(1)=0.D0 + LEVV(1)=0 + ILOFF=1 + IF (NLEVEL.GT.0) GO TO 1200 + WRITE(6,601) JMIN,JMAX,JSTEP + 601 FORMAT('0 JLEVEL, NLEVEL CREATED FROM JMIN, JMAX, JSTEP =', + & 3I5) + JMIN=MAX0(JMIN,0) + JMAX=MAX0(JMIN,JMAX) + JSTEP=MAX0(JSTEP,1) + MAX=0 + NLEVEL=0 + DO 1100 I=JMIN,JMAX,JSTEP + IF (NLEVEL.GE.MXJL) GO TO 1109 + NLEVEL=NLEVEL+1 + JLEVEL(NLEVEL)=I + 1100 MAX=MAX0(MAX,I) + GO TO 9000 + 1109 WRITE(6,698) + 698 FORMAT('0 * * * WARNING. OUT OF SPACE IN JLEVEL. ', + 1 'BASIS TRUNCATED.') + NLEVEL=MXJL + GO TO 9000 + 1200 WRITE(6,602) NLEVEL,(JLEVEL(I),I=1,NLEVEL) + 602 FORMAT('0 BASIS TAKEN FROM NLEVEL, JLEVEL INPUT. NO. OF LEVELS ', + & '(NLEVEL) =',I4/(' ',20I5) ) + MAX=0 + DO 1300 I=1,NLEVEL + IF (I.GT.MXJL) GO TO 1109 + 1300 MAX=MAX0(MAX,JLEVEL(I)) + GO TO 9000 +C +C>>SG --------- CODE REWORKED FEB 92 (ANTICIPATING H2-H CALCULATIONS) + 2000 ILOFF=3 +C MODS FEB 94 TO USE IV() INDEXING FOR ITYPE=2 REQUIRE IVLFL=1 + IVLFL=1 + ASSIGN 6200 TO IGOTP +C + IF (NLEVEL.GT.0) GO TO 2100 +C -------- GET 'VIBRATIONAL LEVELS' FROM SPECIAL SUBROUTINE ------- + WRITE(6,697) + 697 FORMAT('0 IOSBIN (FEB 92). NLEVEL.LT.0. AN APPROPRIATE', + 1 ' SUBROUTINE MUST BE PROVIDED:'/ + 2 35X,'GET102(MXJL,NLEVEL,JLEVEL,ELEVEL)'/) + CALL GET102(MXJL,NLEVEL,JLEVEL,ELEVEL) + NVC=NLEVEL + MAX=0 + DO 2190 I=1,NVC + EV(I)=ELEVEL(I) + LEVV(I)=JLEVEL(2*I) + 2190 MAX=MAX0(MAX,JLEVEL(2*I-1)) +C SKIP '2009' PRINT OUT OF LEVEL INFO/ DO IT IN GET102 IF DESIRED + GO TO 9000 +C +C ----- GET 'VIBRATIONAL LEVELS' FROM JLEVEL ----- +C CURRENT CODE DOES NOT ALLOW DUPLICATE VIB LEVELS. + 2100 NVC=1 + ITOP=2*NLEVEL + WRITE(6,602) NLEVEL,(JLEVEL(I),I=1,ITOP) + LEVV(1)=JLEVEL(2) + MAX=JLEVEL(1) + I=2 + 2102 IF (I.GT.NLEVEL) GO TO 2110 + DO 2103 II=1,NVC + IF (LEVV(II).NE.JLEVEL(2*I)) GO TO 2103 + WRITE(6,693) I,JLEVEL(2*I-1),JLEVEL(2*I) + 693 FORMAT(' IOSBIN (FEB 92). LEVEL',I4,' V,J =',2I4,' DUPLICATES' + 1 ,' AN EARLIER VIB LEVEL.'/ + 2 20X,'VIBRATIONAL VALUE IGNORED, HIGHER J-VALUE KEPT.') + JXX=MAX0(JLEVEL(2*II-1),JLEVEL(2*I-1)) + JLEVEL(2*II-1)=JXX + MAX=MAX0(MAX,JXX) + IF (I.LT.NLEVEL) GO TO 2120 +C I.EQ.NLEVEL ==> REDUCE NLEVEL AND GET OUT + NLEVEL=NLEVEL-1 + GO TO 2110 +C PULL DOWN LIST/ DECREASE NLEVEL/ GO BACK FOR NEW I-TH LEVEL + 2120 DO 2121 J=I+1,NLEVEL + ELEVEL(J-1)=ELEVEL(J) + JLEVEL(2*J-3)=JLEVEL(2*J-1) + 2121 JLEVEL(2*J-2)=JLEVEL(2*J) + NLEVEL=NLEVEL-1 + GO TO 2102 + 2103 CONTINUE +C DUPLICATE VIB LEVEL NOT FOUND/ ADD THIS VIBRATIONAL LEVEL + IF (NVC.LT.NVCMX) GO TO 2104 + WRITE(6,694) NVCMX + 694 FORMAT('0 ISOBIN -- ERROR. VIBRATIONAL LEVELS IN NLEVEL/JLEVEL' + 1 ,' EXCEED NVCMX =',I4) + STOP + 2104 NVC=NVC+1 + LEVV(NVC)=JLEVEL(2*I) + MAX=MAX0(MAX,JLEVEL(2*I-1)) + I=I+1 + GO TO 2102 +C + 2110 WRITE(6,692) NVC + 692 FORMAT('0 IOSBIN (FEB 92). NUMBER OF VIB. CHANNELS (NVC) =',I4) +C +C ----- GET ENERGY LEVELS ----- + DO 2111 I=1,NVC + IF (ELEVEL(I).EQ.0.) GO TO 2111 +C IF ELEVEL() VALUES ARE SET (NON-ZERO), USE THEM + GO TO 2290 + 2111 CONTINUE +C IF WE REACH HERE, ALL ELEVEL ARE ZERO. +C IF THERE IS ONLY ONE LEVEL, AND ENERGY()=0, WE ARE STILL OKEY + IF (NVC.GT.1) GO TO 2280 +C SET EV() FROM ELEVEL() AND WE ARE DONE. + 2290 WRITE(6,691) + 691 FORMAT('0 IOSBIN (FEB 92). VIBRATIONAL ENERGIES ', + 1 'TAKEN FROM ELEVEL INPUT.') + DO 2291 I=1,NVC + 2291 EV(I)=ELEVEL(I) + GO TO 2009 +C OTHERWISE, SEE IF WE CAN CALCULATE ENERGIES FROM WE, WEXE + 2280 IF (WE(1).GT.0.D0) GO TO 2200 + WRITE(6,696) NVC,WE(1) + 696 FORMAT('0 IOSBIN (FEB 92) CANNOT GET ENERGIES FROM ELEVEL ', + & 'OR WE. NVC, WE =',I6,D14.4) + STOP + 2200 WRITE(6,603) WE(1) + 603 FORMAT('0 TARGET ENERGY LEVELS (TAKING V = 0 AS ZERO ENERGY)', + 1 ' COMPUTED FROM WE =',F10.4) + IF (WEXE(1).NE.0.D0) WRITE(6,604) WEXE(1) + 604 FORMAT(67X,'CORRECTED FOR WEXE =',F10.6) + DO 2201 I=1,NVC + FV=LEVV(I) + EV(I)=WE(1)*FV-WEXE(1)*FV*(FV+1.D0) +C STORE BACK IN JLEVEL,ELEVEL FOR ISAVEU OUTPUT PURPOSES. +C>>SG JLEVEL(I)=LEVV(I) -->> THIS WAS USED FOR ISAVEU CAPABILITY IN +C>>SG -->> IOSDRV AND WILL NO LONGER WORK THERE +C ELEVEL() IS NEEDED IN IOSB2 TO GET EINT, ETC. + 2201 ELEVEL(I)=EV(I) + NLEVEL=NVC +C ------ OUTPUT LEVV, EV ------ + 2009 DO 2019 I=1,NVC + 2019 WRITE(6,613) I,LEVV(I),EV(I) + 613 FORMAT(' LEVEL',I4,' LEVV =',I4,' EV =',F12.4) + GO TO 9000 +C<>SG ----- ITYPE=3 CODE ADDED 5/6/92 (SG) + 3000 ILOFF=3 + ASSIGN 6300 TO IGOTP + NVC=1 + LEVV(1)=0 + EV(1)=0. + IF (NLEVEL.GT.0) GO TO 3901 + WRITE(6,632) JMIN,JMAX,JSTEP,J2MIN,J2MAX,J2STEP + 632 FORMAT('0 ROTATIONAL LEVELS FROM JMIN JMAX JSTEP'/ + 1 ' ROTOR 1 -- ',3I5/' ROTOR 2 -- ',3I5) + GO TO 3903 + 3901 ITOP=2*NLEVEL + WRITE(6,633) NLEVEL,(JLEVEL(I),I=1,ITOP) + 633 FORMAT('0 ROTATIONAL LEVELS FROM NLEVEL =',I4,' -- JLEVEL ='/ + 1 (25I4)) + DO 3902 I=1,NLEVEL + JMIN=MIN0(JMIN,JLEVEL(2*I-1)) + JMAX=MAX0(JMAX,JLEVEL(2*I-1)) + J2MIN=MIN0(J2MIN,JLEVEL(2*I)) + 3902 J2MAX=MAX0(J2MAX,JLEVEL(2*I)) + 3903 MAX=MAX0(JMAX,J2MAX) + IF (IDENT.GT.0) WRITE(6,634) IDENT + 634 FORMAT('0 IDENTICAL PARTICLES SPECIFIED BY IDENT =',I3) + GO TO 9000 +C<>SG IN CASE ONLY LAMBDA=0 TERMS APPEAR IN THE POTENTIAL (E.G., IN +C A BREATHING SPHERE TYPE VIBRATIONAL CALC) THE CODE BELOW WILL +C (ERRONEOUSLY) SET LVRTP=.TRUE. HOWEVER, SINCE THE POTENTIAL +C IS THEN SPHERICALLY SYMMETRIC, THIS OUGHT TO STILL WORK. ONE +C MIGHT, WORRY, HOWEVER, ABOUT IHOMO SETTING, AND DOUBLE CHECK +C BEFORE RUNNING SUCH A CASE +C<>SG 5/11/92 +C>>SG 5/11/92 N.B. THIS SHOULD BE REDONE TO TAKE ADVANTAGE OF NEW GAUSSP +C>>SG 5/11/92 + 3500 IF (.NOT.LVRTP) GO TO 3540 + IHOMO=1 + IF (IH0.EQ.0) GO TO 3543 + IHOMO=IH0 + GO TO 3543 +C ABOVE ALLOWS SETTING IN VRTP ROUTINE/ BELOW CHECKS INPUT L,M SYMS. + 3540 IHOMO=2 + DO 3542 L=1,MXLAM + IF (ODD(LAM(2*L),LAM(2*L-1))) IHOMO=1 + 3542 CONTINUE + 3543 THLO=-1.D0 + THHI=1.D0 + SFACT=1.D0 + IF (IHOMO.EQ.1) GO TO 3541 + WRITE(6,618) + 618 FORMAT('0 * * * NOTE.'/' * * * NOTE. USE WILL BE MADE OF FACT ', + & 'THAT POTENTIAL IS SYMMETRIC ABOUT THETA=PI/2'/' * * * NOTE.') + THLO=0.D0 + SFACT=2.D0 +C NEXT GET ICNSYM (OLD CODE SHOULD ALWAYS STILL WORK OKEY) + 3541 LMBDMX=MXXXXL + MUMX=0 + DO 3501 L=1,MXLAM + 3501 MUMX=MAX0(MUMX,IABS(LAM(2*L))) +C FIND ICNSYM WHICH IS PHI EQUIVALENT OF IHOMO + IF (MUMX.GT.1) GO TO 3502 +C ALLOW SETTING OF ICNSYM FOR 'MXSYM=0' (UNEXPANDED POTL) CASE + ICNSYM=1 + IF (.NOT.LVRTP .OR. IC0.EQ.0) GO TO 3503 + ICNSYM=IC0 + WRITE(6,654) ICNSYM + 654 FORMAT('0 * * * NOTE. ICNSYM TAKEN FROM VRTP ROUTINE =',I4) + GO TO 3503 + 3502 ICNSYM=MUMX + 3506 DO 3504 L=1,MXLAM + M=IABS(LAM(2*L)) + IF (M-(M/ICNSYM)*ICNSYM .NE. 0) GO TO 3505 + 3504 CONTINUE + GO TO 3503 + 3505 ICNSYM=ICNSYM-1 + IF (ICNSYM.GT.1) GO TO 3506 + 3503 PHILO=0.D0 + PHIHI=PI/DBLE(ICNSYM) + SFACT=SFACT*DBLE(ICNSYM)*2.D0 +C N.B. WE USE HERE FACT THAT POTENTIAL IS EVEN IN PHI SO INTEGRAL +C IS TWICE THAT FROM 0 TO PI. THIS IS REFLECTED IN HAVING ONLY +C COS (M*PHI) AND NOT SIN (M*PHI) IN PWGHT, ETC. + IF (ICNSYM.GT.1) WRITE(6,658) ICNSYM + 658 FORMAT('0 * * * NOTE.'/' * * * NOTE. USE WILL BE MADE OF',I4 + & ,'-FOLD SYMMETRY ABOUT Z-AXIS.'/' * * * NOTE.') +C DETERMINE NO. OF LAMBDA, MU SYMMETRIES (MXXXXL) + MXXXXL=0 + DO 3507 L=IZ,LMBDMX + MTOP=MIN0(MUMX,L) + DO 3507 M=IZ,MTOP,ICNSYM + IF (IHOMO.EQ.2 .AND. ODD(L,M)) GO TO 3507 + MXXXXL=MXXXXL+1 + 3507 CONTINUE +C DETERMINE NO. OF GAUSSPOINTS FOR THETH(NGL) AND PHI (NGM) +C ** N.B. SOME MANEUVERING IS NECESSARY SINCE GAUSSP MAY REDUCE NPT. + WRITE(6,645) IPHIFL + 645 FORMAT('0 * * * NOTE. IPHIFL (PHI INTEGRATION FLAG) =',I4) + IPASS=0 + IF (IOSNGP(1).GT.0) GO TO 3510 + NGL=2*(MAX+LMBDMX) + WRITE(6,656) NGL,MAX,LMBDMX + 656 FORMAT('0 * * * NOTE. INPUT IOSNGP(1) .LE. 0 (DEFAULT). ', + & 'NGL =',I4,' COMPUTED FROM MAX, LMBDMX =',2I4) + GO TO 3531 + 3510 NGL=IOSNGP(1) + WRITE(6,655) NGL,IOSNGP(1) + 655 FORMAT('0 * * * NOTE. NGL =',I4,' TAKEN FROM', + & ' &BASIS IOSNGP(1) =',I4) + 3531 IF (IOSNGP(2).GT.0) GO TO 3532 + NGM=MAX0(1,2*(MUMX+MXK)) + WRITE(6,647) NGM,MXK,MUMX + 647 FORMAT('0 * * * NOTE. INPUT IOSNGP(2) .LE. 0 (DEFAULT). NGM =', + & I4, ' COMPUTED FROM MXK, MUMX =',2I4) + GO TO 3511 + 3532 WRITE(6,646) IOSNGP(2) + 646 FORMAT('0 * * * NOTE. NGM SET FROM &BASIS IOSNGP(2) =',I4) + NGM=MAX0(1,IOSNGP(2)) + 3511 CALL GAUSSP(THLO,THHI,NGL,COSA,GWT) + IF (MUMX.GT.0 .OR. IPASS.GT.0 .OR.LVRTP) GO TO 3512 + NGM=1 + WRITE(6,650) + 650 FORMAT('0 * * * NOTE.'/' * * * NOTE. POTENTIAL HAS NO PHI ', + & 'DEPENDENCE. INTEGRAL DONE ANALYTICALLY.') + 3512 IF (IPHIFL.NE.0) + &CALL GAUSSP(PHILO,PHIHI,NGM,COSA,GWT) + NGPT=NGM+NGL + IF (NGPT.LE.MXGPT) GO TO 3513 + WRITE(6,607) NGPT,MXGPT + NGL=(DBLE(MXGPT)/DBLE(NGPT))*NGL + NGM=(DBLE(MXGPT)/DBLE(NGPT))*NGM + NGM=MAX0(NGM,1) + IPASS=1 + GO TO 3511 + 3513 CALL GAUSSP(THLO,THHI,NGL,COSA,GWT) + WRITE(6,609) NGL,(COSA(I),GWT(I),I=1,NGL) + IF (IPHIFL.EQ.0) GO TO 3515 + CALL GAUSSP(PHILO,PHIHI,NGM,COSA(NGL+1),GWT(NGL+1)) + WRITE(6,644) NGM,(COSA(NGL+I),GWT(NGL+I),I=1,NGM) + 644 FORMAT('0 PHI INTEGRATION DONE BY ',I3,'-POINT GAUSSIAN ', + & 'QUADRATURE. POINTS/WEIGHTS ARE'/(4(10X,2F10.6))) + GO TO 3516 + 3515 IX=NGL + FACTL=(PHIHI-PHILO)/DBLE(NGM) + TH=-FACTL/2.D0 + DO 3514 I=1,NGM + IX=IX+1 + TH=TH+FACTL + GWT(IX)=FACTL + 3514 COSA(IX)=TH + WRITE(6,651) NGM,(COSA(NGL+I),GWT(NGL+I),I=1,NGM) + 651 FORMAT('0 PHI INTEGRATION DONE BY ',I3,'-POINT GAUSS-MEHLER ', + & 'CHEBYSCHEV) QUADRATURE. POINTS/WEIGHTS ARE'/(4(10X,2F10.6))) + 3516 WRITE(6,653) SFACT + 653 FORMAT('0 ABOVE WEIGHTS MULTIPLIED BY SYMMETRY FACTOR =',D16.8) + NGPT=NGL*NGM +C NEXT CHOOSE LMAX (LMMAX,MUMAX) + IF (LMAX.LE.0) GO TO 3520 + WRITE(6,610) LMAX + LMMAX=LMAX + GO TO 3523 + 3520 LMMAX=MIN0(NGL*IHOMO,2*MAX) + WRITE(6,612) LMMAX +C INPUT CAPABILITY ON MMAX ADDED IN VERSION 6. + 3523 IF (MMAX.LE.0) GO TO 3525 + MUMAX=MMAX + WRITE(6,630) MMAX + 630 FORMAT('0 MMAX TAKEN FROM &INPUT MMAX =',I5) + GO TO 3524 + 3525 MUMAX=MIN0(NGM*ICNSYM,2*MXK,LMMAX) + WRITE(6,631) MUMAX + 631 FORMAT('0 * * * WARNING. MMAX=0 (DEFAULT). WILL USE HIGHEST', + & ' VALUE CONSISTENT WITH IOSNGP(2), MMAX =',I4) +C RESET LMAX TO REFLECT *NUMBER* OF LAMBDA,MU VALUES. +C AND COUNT NQL (NUMBER OF QLT VALUES) + 3524 LMAX=0 + NQL=0 + DO 3521 L=IZ,LMMAX + MTOP=MIN0(MUMAX,L) + DO 3521 M=IZ,MTOP,ICNSYM + IF (IHOMO.EQ.2 .AND. ODD(L,M)) GO TO 3521 + LMAX=LMAX+1 + DO 3522 I=IZ,M,ICNSYM + IF (IHOMO.EQ.2 .AND. ODD(L,I)) GO TO 3522 + IX=2 + IF (I.EQ.M) IX=1 + NQL=NQL+IX + 3522 CONTINUE + 3521 CONTINUE + NIXQL=3 + RETURN +C +C ITYPE=3 CODE ADDED 5/6/92 (SG) +C GET POTENL SYMS. (ITYPE=3 USES IHOMO,ICNSYM FOR IHOMO1,IHOMO2) + 3330 L1MAX=0 + L2MAX=0 + LLMAX=0 + IL=0 + DO 3331 I=1,MXLAM + L1MAX=MAX0(L1MAX,LAM(IL+1)) + L2MAX=MAX0(L2MAX,LAM(IL+2)) + LLMAX=MAX0(LLMAX,LAM(IL+3)) + 3331 IL=IL+ILOFF + MXXXXL=MAX0(MXXXXL,L1MAX,L2MAX,LLMAX) + LVRTP=MXXXXL.LE.0 + IF (.NOT.LVRTP) GO TO 3332 +C ?? MXXXXL=1 THIS WILL BE TAKEN CARE OF IN 3336 LOOP + IHOMO=1 + ICNSYM=1 + IF (IH0.EQ.0) GO TO 3333 + IHOMO=IH0 + WRITE(6,637) IHOMO + 637 FORMAT('0 * * * NOTE. IHOMO (MOL 1) TAKEN FROM VRTP ROUTINE =',I4) + 3333 IF (IC0.EQ.0) GO TO 3334 + ICNSYM=IC0 + WRITE(6,638) ICNSYM + 638 FORMAT('0 * * * NOTE. IHOMO (MOL 2) TAKEN FROM VRTP ROUTINE =',I4) + GO TO 3334 +C FOR EXPANDED POTENTIAL (.NOT.LVRTP) GET IHOMO1,IHOMO2 FROM LAM + 3332 IHOMO=2 + ICNSYM=2 + DO 3335 I=1,MXLAM + IF (ODD(LAM(3*I-2),0)) IHOMO=1 + 3335 IF (ODD(LAM(3*I-1),0)) ICNSYM=1 + 3334 IM=1 + IF (IHOMO.EQ.2) WRITE(6,639) IM + 639 FORMAT('0 * * * NOTE.'/' * * * NOTE. USE WILL BE MADE OF FACT ', + & 'THAT POTENTIAL IS SYMMETRIC ABOUT PI/2 FOR MOLECULE',I3) + IM=2 + IF (ICNSYM.EQ.2) WRITE(6,639) IM +C>>SG (5/18/92) STORE IHOMO,ICNSYM BACK IN IH0,IC0 FOR USE IN IOSOUT + IH0=IHOMO + IC0=ICNSYM +C COUNT L1,L2,LL SYMMETRIES (MXXXXL) +C FOR IDENT PARTICLES, L1,L2<->L2,L1 MUST BOTH BE IN POTL SYMS + MXXXXL=0 + DO 3336 L1=IZ,L1MAX,IHOMO + L2TOP=L2MAX + IF (IDENT.GT.0) L2TOP=L1MAX + DO 3336 L2=IZ,L2TOP,ICNSYM + LLO=ABS(L1-L2) + LHI=L1+L2 + DO 3336 LL=LLO,LHI + IF (ODD(L1+L2,LL)) GO TO 3336 + MXXXXL=MXXXXL+1 + 3336 CONTINUE +C SET INTEGRATION LIMITS AND GET GAUSS POINTS +C CURRENT GAUSSP (5/6/92) DOES *ARBITRARY* NO PTS; +C IF REQUEST EXCEEDS DIMENSIONS (MXGPT) TERMINATE. + SFACT=1.D0 + IF (IOSNGP(1)*IOSNGP(2)*IOSNGP(3).GT.0 .AND. + 1 IOSNGP(1)+IOSNGP(2)+IOSNGP(3).LE.MXGPT) GO TO 3337 + WRITE(6,636) IOSNGP,MXGPT + 636 FORMAT('0 IOSBGP. ERROR. IOSNGP INPUT, ',3I5,' ILLEGAL OR ', + 1 'EXCEEDS STORAGE (MXGPT) =',I5) + STOP + 3337 NGP1=IOSNGP(1) + THLO=-1.D0 + THHI=1.D0 + IF (IHOMO.EQ.2) THEN + THLO=0.D0 + SFACT=SFACT*2.D0 + ENDIF + CALL GAUSSP(THLO,THHI,NGP1,COSA(1),GWT(1)) + WRITE(6,609) NGP1,(COSA(I),GWT(I),I=1,NGP1) + NGP2=IOSNGP(2) + IST2=NGP1 + THLO=-1.D0 + IF (ICNSYM.EQ.2) THEN + THLO=0.D0 + SFACT=SFACT*2.D0 + ENDIF + CALL GAUSSP(THLO,THHI,NGP2,COSA(IST2+1),GWT(IST2+1)) + WRITE(6,609) NGP2,(COSA(IST2+I),GWT(IST2+I),I=1,NGP2) + WRITE(6,645) IPHIFL + PHILO=0.D0 +C CAN ALWAYS USE SYMMETRY V(-PHI)=V(PHI) TO REDUCE INTEGRAL +C FROM (0,2*PI) TO (0,PI) -- CORRECT SFACT ACCORDINGLY + PHIHI=PI + SFACT=SFACT*2.D0 + IST3=IST2+NGP2 + NGM=IOSNGP(3) + IF (IPHIFL.EQ.0) GO TO 3338 + CALL GAUSSP(PHILO,PHIHI,NGM,COSA(IST3+1),GWT(IST3+1)) + WRITE(6,644) NGM,(COSA(IST3+I),GWT(IST3+I),I=1,NGM) + GO TO 3339 + 3338 IX=IST3 + FACTL=(PHIHI-PHILO)/DBLE(NGM) + TH=-FACTL/2.D0 + DO 3342 I=1,NGM + IX=IX+1 + TH=TH+FACTL + GWT(IX)=FACTL + 3342 COSA(IX)=TH + WRITE(6,651) NGM,(COSA(IST3+I),GWT(IST3+I),I=1,NGM) +C SET NGPT AS PRODUCT OF THETA-1, THETA-2, PHI GRIDS + 3339 NGPT=NGP1*NGP2*NGM + WRITE(6,653) SFACT +C RESET LMAX AND NQL=LMAX TO REFLECT NUMBER OF L1,L2,LL VALUES +C USE ITYP=5,6 VARIABLES: LMMAX FOR L1, MUMAX FOR L2 + IF (LMAX.GT.0) GO TO 3340 + LMMAX=(NGP1-1)*IHOMO + WRITE(6,640) LMAX,LMMAX,NGP1,IHOMO + 640 FORMAT('0 &INPUT LMAX =',I4,' -- L1MAX =',I4,' CALCULATED FROM ', + 1 ' NGP1 AND (SYMMETRY) IHOMO =',2I4) + GO TO 3344 + 3340 LMMAX=LMAX + WRITE(6,641) LMAX + 641 FORMAT(' L1MAX TAKEN FROM &INPUT LMAX =',I4) + 3344 IF (MMAX.GT.0) GO TO 3343 + MUMAX=(NGP2-1)*ICNSYM + WRITE(6,642) MMAX,MUMAX,NGP2,ICNSYM + 642 FORMAT('0 &INPUT MMAX =',I4,' -- L2MAX =',I4,' CALCULATED FROM ', + 1 ' NGP2 AND (SYMMETRY) ICNSYM=',2I4) + GO TO 3345 + 3343 MUMAX=MMAX + WRITE(6,643) MMAX + 643 FORMAT(' L2MAX TAKEN FROM &INPUT MMAX =',I4) + 3345 LMAX=0 + DO 3341 L1=IZ,LMMAX,IHOMO + L2TOP=MUMAX +C IDENTICAL PARTICLES KEEP ONLY L1.GE.L2 IN LM(,) + IF (IDENT.GT.0) L2TOP=L1 + DO 3341 L2=IZ,L2TOP,ICNSYM + LLO=ABS(L1-L2) + LHI=L1+L2 + DO 3341 LL=LLO,LHI + IF (ODD(L1+L2,LL)) GO TO 3341 + LMAX=LMAX+1 + 3341 CONTINUE + NQL=LMAX + NIXQL=2 + RETURN +C +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +C + ENTRY IOSB1(PWGHT,VLI,IXQL,LM,NGPT,LMAX,MXXXXL,NIXQL,NQL) +C + IF (ITYP.EQ.3) GO TO 4300 + IF (ITYP.EQ.5 .OR. ITYP.EQ.6) GO TO 4500 +C +C N.B. FOR ITYPE=1,2 LMAX=NQL +C PWGHT MULTIPLY SL(COS(THETA)) TO GET LEGENDRE COEFFICIENTS + FACTL=-.5D0 + DO 4100 L=1,LMAX + IXQL(1,L)=L + IXQL(2,L)=0 + LM1=L-1 + LM(1,L)=LM1 + FACTL=FACTL+1.D0 + DO 4101 NX=1,NGPT +C N.B. WE KEEP EVEN AND ODD L FOR HOMONUCLEARS, BUT SET TO 0. IF NEC + PWGHT(NX,L)=0.D0 + IF (IHOMO.EQ.2 .AND. L-2*(L/2).EQ.0) GO TO 4101 + PWGHT(NX,L)=FACTL*GWT(NX)*XLEG(L-1,COSA(NX)) + 4101 CONTINUE + 4100 CONTINUE +C NEXT COMPUTE VLI + DO 4200 NX=1,NGPT + L=0 + DO 4201 IL=1,MXXXXL + VLI(NX,IL)=XLEG(L,COSA(NX)) + 4201 L=L+IHOMO + 4200 CONTINUE + RETURN +C +C ITYPE=3 -- SETUP VLI + 4300 I=0 + IF (LNEW) GO TO 4993 +C>>SG 5/21/92 BELOW IS OLD CODE - BYPASSED FOR LNEW=.TRUE. + DO 4301 IX1=1,NGP1 + DO 4301 IX2=1,NGP2 + DO 4301 IX3=1,NGM +C I COUNTS GAUSS POINTS TO NGPT. + I=I+1 + IL=0 + DO 4301 L1=IZ,L1MAX,IHOMO + L2TOP=L2MAX + IF (IDENT.GT.0) L2TOP=L1MAX + DO 4301 L2=IZ,L2TOP,ICNSYM + LLO=ABS(L1-L2) + LHI=L1+L2 + DO 4301 LL=LLO,LHI + IF (ODD(L1+L2,LL)) GO TO 4301 +C IL COUNTS SYMMETRIES IN POTENTIAL TO L1MAX,L2MAX + IL=IL+1 + VLI(I,IL)=YRR(L1,L2,LL,COSA(IX1),COSA(IST2+IX2),COSA(IST3+IX3)) + 4301 CONTINUE + PIFACT=2.D0*PI*SFACT + IL=0 + DO 4302 L1=IZ,LMMAX,IHOMO + L2TOP=MUMAX + IF (IDENT.GT.0) L2TOP=L1 + DO 4302 L2=IZ,L2TOP,ICNSYM + LLO=ABS(L1-L2) + LHI=L1+L2 + DO 4302 LL=LLO,LHI + IF (ODD(L1+L2,LL)) GO TO 4302 + XLFACT=1.D0/(2.D0*LL+1.D0) + IL=IL+1 + IXQL(1,IL)=IL + IXQL(2,IL)=0 + LM(1,IL)=L1 + LM(2,IL)=L2 + LM(3,IL)=LL + I=0 + DO 4303 IX1=1,NGP1 + DO 4303 IX2=1,NGP2 + DO 4303 IX3=1,NGM + I=I+1 + 4303 PWGHT(I,IL)=GWT(IX1)*GWT(IST2+IX2)*GWT(IST3+IX3)* + 1 YRR(L1,L2,LL,COSA(IX1),COSA(IST2+IX2),COSA(IST3+IX3)) + 2 *PIFACT*XLFACT + 4302 CONTINUE + GO TO 4998 +C>>SG 5/21/92 ------- END OF OLD CODE +C +C NEW CODE 5/21/92 MUCH MORE EFFICIENT. YRR() ASSEMBLED AS NEEDED +C AVOIDING RECALCULATION OF THRJ, PLM, ETC. + 4993 DEN=SQRT(4.D0*PI)*2.D0*PI + DO 4310 IL=1,MXXXXL + DO 4310 IX=1,NGPT + 4310 VLI(IX,IL)=0.D0 + MTOP=MIN0(L1MAX,L2MAX) + DO 4311 M=IZ,MTOP + PTM=PARITY3(M) + XM=M + DO 4312 IX=1,NGM + COSM(IX)=COS(XM*COSA(IST3+IX))/DEN + IF (M.EQ.0) GO TO 4312 + COSM(IX)=COSM(IX)*(2.D0*PTM) + 4312 CONTINUE + IL=0 + DO 4313 L1=IZ,L1MAX,IHOMO + IF (L1.LT.M) GO TO 4317 + XL1=L1 + PTL1=PARITY3(L1) + DO 4314 IX=1,NGP1 + 4314 PL1(IX)=PLM(L1,M,COSA(IX))*PTL1 + 4317 L2TOP=L2MAX + IF (IDENT.NE.0) L2TOP=L1MAX + DO 4313 L2=IZ,L2TOP,ICNSYM + IF (L2.LT.M) GO TO 4318 + XL2=L2 + PTL2=PARITY3(L2) + DO 4315 IX=1,NGP2 + 4315 PL2(IX)=PLM(L2,M,COSA(IST2+IX))*PTL2 + 4318 LLO=ABS(L1-L2) + LHI=L1+L2 + DO 4313 LL=LLO,LHI + IF (ODD(L1+L2,LL)) GO TO 4313 + IL=IL+1 + IF (L1.LT.M .OR. L2.LT.M) GO TO 4313 + XL=LL + TJ=THRJ(XL1,XL2,XL,XM,-XM,0.D0)*(2.D0*XL+1.D0) + I=0 + DO 4316 IX1=1,NGP1 + DO 4316 IX2=1,NGP2 + DO 4316 IX3=1,NGM + I=I+1 + 4316 VLI(I,IL)=VLI(I,IL)+PL1(IX1)*PL2(IX2)*COSM(IX3)*TJ + 4313 CONTINUE + 4311 CONTINUE +C +C NOW SET UP IXQL, LM, AND PWGHT +C N.B. PIFACT IS CONSISTENT WITH AGG & CLARY, EQS. (19)-(20) +C AND W/ GOLDFLAM & KOURI, EQS. (68), (69), (89), (121). +C I.E. T(ANGLES)=(4*PI)*SUM(L1,L2,L) T(L1,L2,L)*YRR(L1,L2,L/ANGLES) +C NEW CODE 5/21/92 MUCH MORE EFFICIENT; CALC YRR() LOCALLY + PIFACT=2.D0*PI*SFACT + DO 4320 IL=1,LMAX + DO 4320 IX=1,NGPT + 4320 PWGHT(IX,IL)=0.D0 + MTOP=MIN0(LMMAX,MUMAX) + IF (IDENT.GT.0) MTOP=LMMAX + DO 4321 M=0,MTOP + PTM=PARITY3(M) + XM=M + DO 4322 IX=1,NGM + COSM(IX)=COS(XM*COSA(IST3+IX))/DEN + IF (M.EQ.0) GO TO 4322 + COSM(IX)=COSM(IX)*(2.D0*PTM) + 4322 CONTINUE + IL=0 + DO 4323 L1=IZ,LMMAX,IHOMO + IF (L1.LT.M) GO TO 4324 + XL1=L1 + PTL1=PARITY3(L1) + DO 4325 IX=1,NGP1 + 4325 PL1(IX)=PLM(L1,M,COSA(IX))*PTL1 + 4324 L2TOP=MUMAX + IF (IDENT.GT.0) L2TOP=L1 + DO 4323 L2=IZ,L2TOP,ICNSYM + IF (L2.LT.M) GO TO 4326 + XL2=L2 + PTL2=PARITY3(L2) + DO 4327 IX=1,NGP2 + 4327 PL2(IX)=PLM(L2,M,COSA(IST2+IX))*PTL2 + 4326 LLO=ABS(L1-L2) + LHI=L1+L2 + DO 4323 LL=LLO,LHI + IF (ODD(L1+L2,LL)) GO TO 4323 + IL=IL+1 +C STORE IXQL, LM ONLY FOR M=0 PASS ONLY. + IF (M.GT.0) GO TO 4328 + IXQL(1,IL)=IL + IXQL(2,IL)=0 + LM(1,IL)=L1 + LM(2,IL)=L2 + LM(3,IL)=LL + 4328 IF (L1.LT.M .OR. L2.LT.M) GO TO 4323 + XL=LL +C TJ=THRJ(XL1,XL2,XL,XM,-XM,0.D0)*PIFACT/(2.D0*XL+1.D0) +C 2*L+1 FACTOR CANCELS THAT IN DEF OF YRR ??? + TJ=THRJ(XL1,XL2,XL,XM,-XM,0.D0)*PIFACT + I=0 + DO 4329 IX1=1,NGP1 + DO 4329 IX2=1,NGP2 + DO 4329 IX3=1,NGM + I=I+1 + 4329 PWGHT(I,IL)=PWGHT(I,IL)+PL1(IX1)*PL2(IX2)*COSM(IX3)*TJ + 4323 CONTINUE + 4321 CONTINUE +C END OF M-LOOP - PWGHT NOW CONTAINS YRR; NEED TO MULT BY GAUSS WTS + I=0 + DO 4330 IX1=1,NGP1 + DO 4330 IX2=1,NGP2 + DO 4330 IX3=1,NGM + I=I+1 + WTFACT=GWT(IX1)*GWT(IST2+IX2)*GWT(IST3+IX3) + DO 4330 IL=1,LMAX + 4330 PWGHT(I,IL)=PWGHT(I,IL)*WTFACT +C + 4998 WRITE(6,659) (I,LM(1,I),LM(2,I),LM(3,I),I=1,LMAX) + 659 FORMAT('0 BI-SPHERICAL HARMONICS FOR EXPANDING S-MATRIX ARE ', + 1'AS FOLLOWS'/'0 INDX L1 L2 LL'/(' ',4I4)) + RETURN +C +C ITYPE=5,6 -- COMPUTE VLI + 4500 I=0 + DO 4501 NX=1,NGL + DO 4501 IX=1,NGM + I=I+1 + IL=0 + DO 4501 L=IZ,LMBDMX + MTOP=MIN0(MUMX,L) + DO 4501 M=IZ,MTOP,ICNSYM + IF (IHOMO.EQ.2 .AND. ODD(L,M)) GO TO 4501 + IL=IL+1 + VLI(I,IL)=PLM(L,M,COSA(NX))/SQRT(2.D0*PI) + IF (M.NE.0) VLI(I,IL)=VLI(I,IL)*2.D0*COS(DBLE(M)*COSA(NGL+IX)) + 4501 CONTINUE +C SETUP PWGHT + FACTL=1.D0/SQRT(2.D0*PI) + IL=0 + DO 4502 L=IZ,LMMAX + MTOP=MIN0(L,MUMAX) + DO 4502 M=IZ,MTOP,ICNSYM + IF (IHOMO.EQ.2 .AND.ODD(L,M)) GO TO 4502 + IL=IL+1 + IV=0 + DO 4503 IX=1,NGL + DO 4503 NX=1,NGM + IV=IV+1 + 4503 PWGHT(IV,IL)=GWT(IX)*GWT(NGL+NX)*PLM(L,M,COSA(IX))* + & COS(DBLE(M)*COSA(NGL+NX))* + 2 (SFACT*FACTL) + 4502 CONTINUE + I=0 + IX=0 + DO 4505 L=IZ,LMMAX + MTOP=MIN0(MUMAX,L) + DO 4505 M=IZ,MTOP,ICNSYM + IF (IHOMO.EQ.2 .AND. ODD(L,M)) GO TO 4505 + I=I+1 + LM(1,I)=L + LM(2,I)=M + DO 4504 IL=1,I + IF (LM(1,IL).NE.L) GO TO 4504 + IX=IX+1 + IXQL(1,IX)=I + IXQL(2,IX)=IL + IF (I.NE.IL) GO TO 4506 + IXQL(3,IX)=0 + GO TO 4504 + 4506 IXQL(3,IX)=1 + IX=IX+1 + IXQL(1,IX)=I + IXQL(2,IX)=IL + IXQL(3,IX)=2 + 4504 CONTINUE + 4505 CONTINUE + WRITE(6,657) (I,LM(1,I),LM(2,I),I=1,LMAX) + 657 FORMAT('0 SPHERICAL HARMONIC SYMMETRIES FOR EXPANDING S-MATRIX ', + 1 'ARE AS FOLLOWS'/'0 INDX L M'/(' ',2I4,I3)) + WRITE(6,649) + 649 FORMAT('0 BELOW ARE INDICES TO SYMMETRIES IN QLT'/ + &'0 IN QLT LM1 L M LM2 L M CODE') + DO 4507 I=1,NQL + IL=IXQL(1,I) + IX=IXQL(2,I) + 4507 WRITE(6,648) I,IL,LM(1,IL),LM(2,IL),IX,LM(1,IX),LM(2,IX),IXQL(3,I) + 648 FORMAT(' ',I7,I6,2I3,I6,2I3,I6) + RETURN +C +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +C + ENTRY IOSB2(JTOT,LORB,JJJ,NB,CENT,EINT,CINT,WVEC,VL,IVIX,IP, + & NVC,ERED,NPOTL,MXLAM,LAM,VLI,NGPT,MXXXXL) +C + XJ=JTOT + XJ=XJ*(XJ+1.D0) + DO 6666 I=1,NVC + LORB(I)=JTOT + JJJ(I)=I + NB(I)=I + CENT(I)=XJ + EINT(I)=CINT*EV(I) + DIF=ERED-EINT(I) + WVEC(I)=SQRT(ABS(DIF)) + IF (DIF.GE.0.D0) GO TO 6666 + WVEC(I)=-WVEC(I) + 6666 CONTINUE +C + GO TO IGOTP,(6100,6200,6300,6500) +C +C CHECK FOR CONSISTENT IVLFL + 6100 IF (IVLFL.NE.0) GO TO 9999 + DO 6101 I=1,MXLAM + IL=LAM(I)/IHOMO + 1 +C IVIX(I)=I + 6101 VL(I)=VLI(IP,IL) +C SET COSANG, FACTOR FOR MXLAM.LE.0 CASE + COSANG(1)=COSA(IP) + FACTOR=1.D0 + GO TO 6900 +C +C>>SG -------------- NEW CODE --------------------->> +C>>SG CHECK FOR NPOTL=1 (LVRTP) OR NPOTL=MXLAM (EXPANDED) +C>>SG LATTER CASE UNCHANGED FROM VERSION 10 CODE +C>>SG JAN 94: *ALL* ITYPE=2 NOW HAVE IVLFL=1; NPOTL.LE.MXLAM + 6200 IF (IVLFL.LE.0) GO TO 9999 +C ZERO IVIX,VL STORAGE + ITOP=NVC*(NVC+1)*NPOTL/2 + DO 6202 IX=1,ITOP + IVIX(IX)=0 + 6202 VL(IX)=0.D0 + IF (.NOT.LVRTP ) GO TO 6250 +C +C UNEXPANDED 'LVRTP' POTENTIAL (BELOW HAS A LOT OF 'DEBUGGING' TEST) + IF (NPOTL.NE.1) THEN + WRITE(6,670) NPOTL,MXLAM + 670 FORMAT('0 IOSB2 (FEB 92) -- ERROR. LVRTP INCONSISTENT WITH', + 1 ' NPOTL, MXLAM',2I6) + STOP + ENDIF + DO 6203 L=1,MXLAM + LLL=LAM(3*L-2) + IL=LLL/IHOMO+1 +C N.B. WE SHOULD HAVE LLL=0 AND IL=1 *** DEBUGGING ONLY *** + IF (LLL.NE.0 .OR. IL.NE.1) WRITE(6,672) LLL,IL + 672 FORMAT('0 IOSB2 (FEB 92) -- ERROR. LLL.NE.0 .OR IL.NE.1',2I6) + IV=LAM(3*L-1) + IVP=LAM(3*L) + IVVP=0 + DO 6204 IROW=1,NVC + NV=LEVV(IROW) + DO 6204 ICOL=1,IROW + NVP=LEVV(ICOL) + IVVP=IVVP+1 + IF (.NOT.((NV.EQ.IV.AND.NVP.EQ.IVP).OR.(NV.EQ.IVP.AND.NVP.EQ.IV))) + 1 GO TO 6204 +C IF WE REACH BELOW, THIS ROW/COL CORRESPONDS TO CURRENT 'SYMMETRY' + IX=(IVVP-1)*NPOTL+LLL+1 +C SINCE NPOTL=1 AND LLL=0, SHOULD HAVE IX=IVVP *** DEBUGGING *** + IF (IX.NE.IVVP) WRITE(6,673) IX,IVVP + 673 FORMAT('0 IOSB2 (FEB 92) -- ERROR. IX.NE.IVVP FOR VL,IVIX',2I6) + IVIX(IX)=L + VL(IX)=VLI(IP,IL) + 6204 CONTINUE + 6203 CONTINUE +C SET COSANG, FACTOR FOR VRTP CASE, AND RETURN + COSANG(1)=COSA(IP) + FACTOR=1.D0 + GO TO 6900 +C +C CODE BELOW FOR POTENTIAL EXPANDED IN LEGENDRE POLY'S +C MODIFIED TO USE IV() INDEXING +C + 6250 IF (MXXXXL.GT.NPOTL) THEN + WRITE(6,*) ' IOSB2. MXXXXL.GT.NPOTL NOT ALLOWED',MXXXXL,NPOTL + STOP + ENDIF + DO 6251 L=1,MXLAM + IL=LAM(3*L-2)/IHOMO + 1 +C DEBUGGING ... + IF (IL.GT.MXXXXL) THEN + WRITE(6,*) ' IOSB2. IL.GT.MXXXXL SHOULD NOT OCCUR',IL,MXXXXL + ENDIF + LV1=LAM(3*L-1) + LV2=LAM(3*L) + IVVP=0 + DO 6252 IV=1,NVC + DO 6252 IVP=1,IV + IVVP=IVVP+1 + IF (LEVV(IV).EQ.LV1 .AND. LEVV(IVP).EQ.LV2) GO TO 6253 + IF (LEVV(IV).EQ.LV2 .AND. LEVV(IVP).EQ.LV1) GO TO 6253 + GO TO 6252 + 6253 IX=(IVVP-1)*NPOTL+IL + IVIX(IX)=L + VL(IX)=VLI(IP,IL) + 6252 CONTINUE + 6251 CONTINUE + GO TO 6900 +C +C CHECK FOR CONSISTENT IVLFL + 6300 IF (IVLFL.NE.0) GO TO 9999 + IL=0 + DO 6301 L1=IZ,L1MAX,IHOMO + L2TOP=L2MAX + IF (IDENT.GT.0) L2TOP=L1MAX + DO 6301 L2=IZ,L2TOP,ICNSYM + LLO=ABS(L1-L2) + LHI=L1+L2 + DO 6301 LL=LLO,LHI + IF (ODD(L1+L2,LL)) GO TO 6301 + IL=IL+1 + DO 6302 I=1,MXLAM + IF (L1.NE.LAM(3*I-2)) GO TO 6302 + IF (L2.NE.LAM(3*I-1)) GO TO 6302 + IF (LL.NE.LAM(3*I )) GO TO 6302 +C IVIX(I)=I + VL(I)=VLI(IP,IL) + IF (LDEBUG) WRITE(6,635) I,L1,L2,LL,IL + 635 FORMAT(' IOSB2. DEBUG. I,L1,L2,LL,IL',5I5) + 6302 CONTINUE + 6301 CONTINUE +C FOR 'VRTP' CASE NEED TO SET COSANG(), FACTOR =(4*PI)**(3/2) + FACTOR=(4.D0*PI)*SQRT(4.D0*PI) +C CALCULATE IX1,IX2,IX3 FROM IP (# OF GAUSS POINT) + IX3=IP + IX1=(IX3-1)/(NGP2*NGM)+1 + IX3=IX3-(IX1-1)*(NGP2*NGM) + IX2=(IX3-1)/NGM+1 + IX3=IX3-(IX2-1)*NGM + COSANG(1)=COSA(IX1) + COSANG(2)=COSA(IST2+IX2) + COSANG(3)=COSA(IST3+IX3) + GO TO 6900 +C<>SG N.B. ITYPE=3 VALUES DIFFER FROM GOLDFLAM-KOURI AND AGG-CLARY +C ITYPE V AVGFCT +C 1,2 1. 1. +C 3 1/4*PI 1./SQRT(4*PI) +C 5,6 1/4*PI 1./SQRT(4*PI) + V=1.D0 + IF (ITYPE.EQ.5.OR.ITYPE.EQ.6.OR.ITYPE.EQ.3) V=1.D0/(4.D0*PI) + AVGFCT=SQRT(V) + CINT=RMLMDA/EPSIL +C INITIALIZE RSTART, IN CASE IRMSET.LE.0 AND FINDRM NOT CALLED + RMINSV=RMIN + RSTART=RMIN + CALL GCLOCK (TITIME) +C +C PRINT LEVEL FOR SCATTERING CAN BE LESS THAN FOR IOS1 +C + IOSPR=MAX0(0,PRINT-10) +C +C +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +C +C LOOP OVER ENERGIES. +C + DO 2000 IE=1,NNRG + ICODE=1 + IF(IE.GT.1 .AND. ISCRU.GT.0) ICODE=2 + IF(ISCRU.GT.0) REWIND ISCRU + WRITE(6,622) IE,ENERGY(IE) + 622 FORMAT('1 IOSCLC (MAY 92). ENERGY(',I3,') =',F12.4,' (1/CM).') + ERED=ENERGY(IE)*CINT + IF (IE.EQ.1) EFIRST=ERED + ESHIFT=ERED-EFIRST +C A MORE SOPHISTICATED WAY OF SAVING RTURN IS PROBABLY WANTED, +C BUT BELOW SHOULD WORK AS A TEMPORARY MEASURE + RTURN=RMINSV +C ZERO STORAGE + DO 2100 I=1,NQL + 2100 IEC(I)=0 + DO 2109 IV=1,NVC + DO 2109 IVP=1,NVC + QLS(IV,IVP)=0.D0 + SIGAV(IV,IVP)=0.D0 + DO 2101 I=1,NQL + 2101 QLT(IV,IVP,I)=0.D0 + DO 2102 I=1,NGPT + 2102 SIGTH(IV,IVP,I)=0.D0 + 2109 CONTINUE +C +C LOOP OVER PARTIAL WAVES +C + DO 3000 JTOT=JTOTL,JTOTU,JSTEP + IF (PRINT.GT.1) WRITE(6,626) JTOT,IE,ENERGY(IE) + 626 FORMAT('0 ***** PARTIAL WAVE =',I5,' FOR ENERGY(',I3,') = ', + & F12.4,' *****') +C + IF (JTOTU.LT.999999) GO TO 3001 +C CHECK FOR CONVERGENCE +C ONLY CHECK FOR QLT WHERE IXQL(NIXQL,IL).EQ.0 + DO 3002 IL=1,LMAX + IF (IXQL(NIXQL,IL).NE.0) GO TO 3002 + IF (IEC(IL).LT.NCAC) GO TO 3001 + 3002 CONTINUE + CALL GCLOCK(TJTIME) + TIME=TJTIME-TITIME + TITIME=TJTIME + JTO=JTOT-JSTEP + WRITE(6,620) IE,ENERGY(IE),LMAX,NCAC,TEST,JTOTL,JSTEP,JTO + 620 FORMAT('1 ***** ***** ***** CALCULATION AT ENERGY(',I3,') =', + 1 F10.2,' (1/CM) ', + & ' TERMINATED DUE TO CONVERGENCE FOR',I4,' Q(L).'/ + & 22X,'NCAC, TEST =',I4,2E12.4/ + 2 22X,'PARTIAL WAVES',I4,' (',I4,' ) ',I5) + WRITE(6,641) TIME + 641 FORMAT('0 ***** ***** ***** TIME WAS',F9.2,' SEC.'/' ') + GO TO 3009 + 3001 FACTL=(2*JTOT+1)*PI +C +C GET ANGLE-DEPENDENT SCATTERING / LOOP OVER GAUSS POINTS. + DO 3100 IP=1,NGPT +C +C INITIALIZE SCAT VARIABLES VL, LORB, EINT, ETC. + CALL IOSB2(JTOT,X(IXLORB),X(IXJJJ),NB,X(IXCENT),X(IXEINT),CINT, + 1 WVEC,X(IXVL),X(IXIV),IP,NVC,ERED,NPOTL,MXLAM,LAMBDA,VLI, + 2 NGPT,MXXXXL) +C + CONV=0.D0 + RTURN=RSTART + IF(ICODE.NE.1) GOTO 3005 + CALL FINDRX(ENERGY(IE),X(IXEINT),X(IXCENT),1,NVC,CINT,RMAX,RSTOP, + 1 NOPMAX,IRXSET,IOSPR) +C + IF(IRMSET.LE.0) GOTO 3005 +C GET TEMPORARY STORAGE FOR FINDRM; MODIFED 23 AUG FOR NEW FINDRM (SG) + IT1=ICX + IT2=IT1+MXLAM + IT3=IT2+NVC + IT4=IT3+NVC + IXNEXT=IT4+NVC + CALL CHKSTR(NUSED) + CALL FINDRM(X(IXSR),NVC,RSTART,RTURN,IK,X(IT1),X(IXVL),X(IXIV), + 1 ERED,X(IXEINT),X(IXCENT),RMLMDA,X(IXSI),X(IT2),X(IT3),X(IT4), + 2 MXLAM,NPOTL,IRMSET,ITYPE,IOSPR) +C RELEASE TEMPORARY STORAGE + IXNEXT=IT1 + IF(RVFAC.EQ.0.D0) GOTO 3005 + RMID=RVFAC*RTURN + IF(IOSPR.GE.3) WRITE(6,3003) RMID,RVFAC + 3003 FORMAT('0 RMID =',F7.2,' OBTAINED FROM RVFAC =',F6.3) +C +C NOW READY TO SOLVE 'COUPLED' EQUATIONS; DONE AS CALL TO STORAG. +C + 3005 NV=NPOTL*NVC*(NVC+1)/2 + CALL STORAG( INTFLG,NVC,MXLAM,NV,NPOTL, + 1 IXJJJ,IXSR,IXSI,IXKMAT,IXVL,IXIV,IXEINT,IXCENT, + 2 IXWV,IXLORB,IXNB, + 3 ESHIFT,NOPMAX,DEEP,IK,ICODE,IOSPR, NUMDER) +C +C INITIALIZE TO UNIT S-MATRIX TO CLEAR 'NON-CLASSICAL' CHANNELS. +C + 4000 DO 4005 IV=1,NVC + DO 4005 IVC=1,NVC + DELVVP=0.D0 + IF (IV.EQ.IVC) DELVVP=1.D0 + SLR(IV,IVC,IP)=DELVVP + 4005 SLI(IV,IVC,IP)=0.D0 + IF (NOPEN.GT.0) GO TO 4009 + WRITE(6,699) IP,NOPEN + 699 FORMAT(' * * * NOTE. FOR ORIENTATION',I6,' NOPEN =',I3) + GO TO 3100 + 4009 IF (NOPEN.LE.NVC) GO TO 4008 + WRITE(6,698) IP,NOPEN,NVC + 698 FORMAT(' * * * ERROR. FOR ORIENTATION',I6,' NOPEN.GT.NVC',2I6) + GO TO 3100 + 4008 IF (CONV.GE.0.D0) GO TO 4007 + WRITE(6,696) JTOT,IP + 696 FORMAT('0 * * * WARNING. SLR,SLI,SIGTH NOT SET DUE TO LACK OF CON + &VERGENCE FOR PART. WAVE',I4,' ORIENTATION',I5) + GO TO 3100 +C + 4007 IF (PRINT.GE.15) WRITE(6,601) + 601 FORMAT(' ') + NNP=0 + DO 4200 N=1,NOPEN + IV=NB(N) + WV=RM/WVEC(IV) +C SET WVEC(IV) TO WAVENUMBER IN 1/ANGSTROMS FOR ISAVEU OUTPUT + WVEC(IV)=1.D0/WV + WV=WV*WV*FACTL + DO 4200 NP=1,NOPEN + IVP=NB(NP) + NNP=NNP+1 + DELVVP=0.D0 + IF (IV.EQ.IVP) DELVVP=1.D0 +C BELOW CHANGED APR 86 SINCE ONLY INDICES FOR SREAL,SIMAG ARE HERE + SLR(IV,IVP,IP)=X(IXSR-1+NNP) + SLI(IV,IVP,IP)=X(IXSI-1+NNP) +C ACCUMULATE ANGLE-DEPENDENT TOTAL CROSS SECTION. + ADD=DELVVP-SLR(IV,IVP,IP) + ADD=(ADD*ADD+SLI(IV,IVP,IP)*SLI(IV,IVP,IP) )*WV + SIGTH(IV,IVP,IP)=SIGTH(IV,IVP,IP)+ADD + IF (PRINT.LT.15) GO TO 4200 + WRITE(6,627) IP,IV,IVP,SLR(IV,IVP,IP),SLI(IV,IVP,IP), + & ADD,SIGTH(IV,IVP,IP) + 627 FORMAT(' FOR ORIENTATION',I6,' VIB LEVEL =',I2,' TO',I2, + & ', SREAL, SIMAG =',2D14.6,' SIGTH ADD',D12.4,' = ',D12.4) + 4200 CONTINUE + 3100 CONTINUE +C END OF LOOP OVER ORIENTATIONS +C +C INTEGRATE OVER ORIENTATIONS TO GET SLLR/SLLI +C ** N.B. THESE ARE T-MATRIX COMPONENTS ** + IF (PRINT.GE.20) WRITE(6,601) + DO 3218 IV=1,NVC + DO 3218 IVP=1,NVC + DELVVP=0.D0 + IF (IV.EQ.IVP) DELVVP=1.D0 + DO 3218 L=1,LMAX + SLLI(IV,IVP,L)=0.D0 + SLLR(IV,IVP,L)=0.D0 + DO 3208 NX=1,NGPT + SLLR(IV,IVP,L)=SLLR(IV,IVP,L)+(DELVVP-SLR(IV,IVP,NX))*PWGHT(NX,L) + 3208 SLLI(IV,IVP,L)=SLLI(IV,IVP,L)-SLI(IV,IVP,NX)*PWGHT(NX,L) + IF (PRINT.GE.20) + & WRITE(6,648) IV,IVP,L,SLLR(IV,IVP,L),SLLI(IV,IVP,L) + 648 FORMAT(5X,3I5, 2D16.8) + 3218 CONTINUE +C +C *** +C>>SG MAY 92. CODE BELOW REPLACED BY CALL ISUTP AT STATEMENT NO. 3000 +C SAVE SLLR/SLLI HRE / N.B. SLR/SLI MIGHT BE USEFUL LATER. +C IF (ISU.LE.0) GO TO 3230 +C WRITE(ISU,3231) JTOT,IE,ENERGY(IE) +C3231 FORMAT(2I4,E16.8) +C WRITE(ISU,3232) NOPEN,(NB(I),JTOT,WVEC(NB(I)),I=1,NOPEN) +C3232 FORMAT(I4/(2I4,E16.8)) +C WRITE(ISU,3233) (((SLLR(NB(IV),NB(IVP),L),IV=1,NOPEN),IVP=1,NOPEN) +C & ,L=1,LMAX) +C WRITE(ISU,3233) (((SLLI(NB(IV),NB(IVP),L),IV=1,NOPEN),IVP=1,NOPEN) +C & ,L=1,LMAX) +C3233 FORMAT(5E16.8) +C *** +C +C COMPUTE QLS (QLOLD PREVIOUSLY) FOR 1ST (TOTALLY SYMMETRIC) CASE + 3230 IF (PRINT.GE.10) WRITE(6,601) + DO 3220 IV=1,NVC +C SET WVEC(IV) TO (2*L+1)*PI/K**2 FOR USE IN GETTING QL'S +C>>SG TRAP CLOSED CHANNELS (NEGATIVE WVEC) TO PREVENT ROUND-OFF PROBLEMS + IF (WVEC(IV).LE.0.) GO TO 3220 + WVEC(IV)=FACTL/(WVEC(IV)*WVEC(IV)) + DO 3219 IVP=1,NVC + DELVVP=0.D0 + IF (IV.EQ.IVP) DELVVP=1.D0 + SUMR=0.D0 + SUMI=0.D0 + DO 3209 NX=1,NGPT + SUMR=SUMR+PWGHT(NX,1)*SLR(IV,IVP,NX) + SUMI=SUMI+PWGHT(NX,1)*SLI(IV,IVP,NX) + 3209 CONTINUE +C>>SG BELOW SUFFERS FROM ROUND-OFF ERROR FOR IV=IVP CLOSED +C>>SG TEST CASES GIVE V*(SUMR**2+SUMI**2)-DELVVP ABOUT 2.D-13 +C>>SG BEST WAY TO FIX THIS IS PROBABLY TO TRAP *CLOSED* CHANNELS + SUM2=(V*(SUMR*SUMR+SUMI*SUMI)-DELVVP)*WVEC(IV) + QLS (IV,IVP)=QLS (IV,IVP)+SUM2 + IF (PRINT.GE.10) WRITE(6,638) IV,IVP,SUM2, QLS(IV,IVP) + 638 FORMAT(' FOR QLS( 0) VIB LEV =',I3,' TO',I3,15X, + & 'ADD',D12.4,' =',D12.4) + 3219 CONTINUE + 3220 CONTINUE +C +C *** IN ACCUMULATING QL DIVERGENT CODE FOR ITYPE=1,2 AND ITYPE=5,6 +C + IF (ITYPE.EQ.1 .OR. ITYPE.EQ.2) GO TO 8881 + IF (ITYPE.EQ.3) GO TO 8883 + IF (ITYPE.EQ.5 .OR. ITYPE.EQ.6) GO TO 8885 + STOP +C +C ACCUMULATE QL'S / TEST FOR CONVERGENCE + 8881 BIGL=-1.D0 + DO 3200 L=1,NQL + LMP=L-1 + BIGL=BIGL+2.D0 + ITEST=0 + IF (PRINT.GE.10 .AND. NVC.GT.1) WRITE(6,601) + DO 3210 IV=1,NVC + DO 3210 IVP=1,NVC + TLLR=SLLR(IV,IVP,L) + TLLI=SLLI(IV,IVP,L) + TLLSQ=(TLLR*TLLR+TLLI*TLLI)*V*WVEC(IV)/BIGL + QLT(IV,IVP,L)=QLT(IV,IVP,L)+TLLSQ + XTEST=TEST(1) + IF (L.GT.1 .OR. IV.NE.IVP) XTEST=TEST(2) + IF (TLLSQ.GT.XTEST) ITEST=1 + IF (PRINT.LT.10) GO TO 3210 + WRITE(6,628) LMP,IV,IVP,TLLSQ,QLT(IV,IVP,L) + 628 FORMAT(' FOR QLT(',I3,') VIB LEV =',I3,' TO',I3, + & ' IOS T-MATRIX ADD',D12.4,' =',D12.4) + 3210 CONTINUE +C>>SG 5/12/92 STATEMENT BELOW SHOULD BE UNNECESSARY + IF (JTOTU.LT.999999) GO TO 3200 +C SUPPRESS CONVERGENCE CHECK FOR LOW PARTIAL WAVES. + IF (JTOT.LE.3*JSTEP*NCAC) GO TO 3200 + IF (IXQL(NIXQL,L).NE.0) GO TO 3200 + IEC(L)=IEC(L)+1 + IF (ITEST.GT.0) IEC(L)=0 + 3200 CONTINUE + GO TO 3000 +C + 8883 DO 8873 IL=1,NQL + BIGL=(2*LM(3,IL)+1) +C N.B. NVC=1 FOR ITYPE=3 + TLLR=SLLR(1,1,IL) + TLLI=SLLI(1,1,IL) + TLLSQ=(TLLR*TLLR+TLLI*TLLI)*V*WVEC(1) * BIGL + QLT(1,1,IL)=QLT(1,1,IL)+TLLSQ + IF (PRINT.GE.10) WRITE(6,652) IL,LM(1,IL),LM(2,IL),LM(3,IL), + 2 TLLSQ,QLT(1,1,IL) + 652 FORMAT(' FOR QLT(',I3,'), L1,L2,L =',3I3,' ADD', + 1 D12.4,' =',D12.4) + XTEST=TEST(MIN0(2,IL)) + IF (JTOT.LE.3*JSTEP*NCAC) GO TO 8873 +C IF (IXQL(NIXQL,IL).NE.0) GO TO 8875 --- SHOULD ALL = 0 + IEC(IL)=IEC(IL)+1 + IF (TLLSQ.GT.XTEST) IEC(IL)=0 + 8873 CONTINUE + GO TO 3000 +C + 8885 DO 8875 IL=1,NQL +C N.B. NVC=1 FOR ITYPE=5,6 + TLLR=SLLR(1,1,IXQL(1,IL)) + TLLI=SLLI(1,1,IXQL(1,IL)) + TLLR1=SLLR(1,1,IXQL(2,IL)) + TLLI1=SLLI(1,1,IXQL(2,IL)) + IF (IXQL(3,IL).EQ.2) GO TO 8865 +C BELOW FOR REAL PART / ALSO FOR DIAGONAL CASES + TLLSQ=(TLLR*TLLR1+TLLI*TLLI1)*V*WVEC(1) + GO TO 8855 +C BELOW FOR IMAGINARY PART + 8865 TLLSQ=(TLLI*TLLR1-TLLR*TLLI1)*V*WVEC(1) + 8855 QLT(1,1,IL)=QLT(1,1,IL)+TLLSQ + IF (PRINT.GE.10) WRITE(6,651) IL,LM(1,IXQL(1,IL)),LM(2,IXQL(1,IL)) + 1 ,LM(2,IXQL(2,IL)),IXQL(3,IL), + 2 TLLSQ,QLT(1,1,IL) + 651 FORMAT(' FOR QLT(',I3,'), L,M,M1 =',3I4,', CODE =',I2,' ADD', + 1 D12.4,' =',D12.4) + XTEST=TEST(MIN0(2,IL)) + IF (JTOT.LE.3*JSTEP*NCAC) GO TO 8875 + IF (IXQL(3,IL).NE.0) GO TO 8875 + IEC(IL)=IEC(IL)+1 + IF (TLLSQ.GT.XTEST) IEC(IL)=0 + 8875 CONTINUE + GO TO 3000 +C + 3000 CALL ISUTP(ISU,ENERGY(IE),JTOTL,JSTEP,JTOT,NVC,NQL,QLS,QLT) +C END OF LOOP OVER PARTIAL WAVES +C + CALL GCLOCK(TJTIME) + TIME=TJTIME-TITIME + TITIME=TJTIME + WRITE(6,631) ENERGY(IE),JTOTL,JSTEP,JTOTU + 631 FORMAT('1 ***** ***** ***** END OF CALCULATION FOR ENERGY =', + 1 F12.4,' (1/CM) ***** ***** *****'/ + & 22X,'PARTIAL WAVES',I4,' (',I4,' ) ',I5) + WRITE(6,641) TIME +C +C END OF CALCULATION FOR THIS ENERGY / OUTPUT CROSS SECTIONS +C MAKE SURE WE HAVE NUSED BY CALLING CHKSTR + 3009 CALL CHKSTR(NUSED) + WRITE(6,684) NUSED,MX + 684 FORMAT('0',2(' *****'),' STORAGE SO FAR USED',I10,' OF THE', + 1 I10,' AVAILABLE WORDS.') +C>>SG +C>>SG N.B. NVC SHOULD BE LOWERED TO NOUT=NOPEN (AS IN IOSOUT) +C>>SG + DO 3305 NX=1,NGPT + IV=1 + WRITE(6,632) NX,(LEFT,IV,IVP,SIGTH(IV,IVP,NX),IVP=1,NVC) + 632 FORMAT('0 FOR ORIENTATION',I6,3(5X,A4 ,I2,',',I2,') =',1PE12.4) + & /(23X,3(5X,A4,I2,',',I2,') =',1PE12.4))) + IF (NVC.LE.1) GO TO 3008 + DO 3007 IV=2,NVC + 3007 WRITE(6,642) (LEFT,IV,IVP,SIGTH(IV,IVP,NX),IVP=1,NVC) +C>>SG FORMAT CHANGED 2/6/92 TO ELIMINATE APPARENT COMPILER BUG + 642 FORMAT(23X,3(5X, A4, I2,',',I2,') =',1PE12.4)/ + 1 (23X,3(5X, A4, I2,',',I2,') =',1PE12.4))) + 3008 DO 3305 IV=1,NVC + DO 3305 IVP=1,NVC + 3305 SIGAV(IV,IVP)=SIGAV(IV,IVP)+PWGHT(NX,1)*SIGTH(IV,IVP,NX)*AVGFCT + WRITE(6,643) + 643 FORMAT('0 AVERAGE OVER ORIENTATIONS') + DO 3004 IV=1,NVC + 3004 WRITE(6,642) (LEFT,IV,IVP,SIGAV(IV,IVP),IVP=1,NVC) +C +C CALL IOSOUT/IOSPB TO GET STATE TO STATE AND PR. BR. CROSS SECTIONS +C N.B. ATAU, NEEDED ONLY FOR SIG6, IS STORED IN X(1), I.E., JLEV. +C THIS IS PRETTY BAD CODING; BETTER PASSING OF ATAU TO SIG6 NEEDED +C + IATAU=1 + CALL IOSOUT(ENERGY(IE),QLT,QLS,NVC,ITYPE,X(IATAU),LM,IXQL, + 1 LMAX,NIXQL,NQL,JSTEP) + IF(IFLS.GT.0) + 1CALL IOSPB(ENERGY(IE),QLT,QLS,IFLS,LINE,LTYPE,ITYPE,NVC,LM,IXQL, + 1 LMAX,NIXQL,NQL) +C + 2000 CONTINUE +C +C END OF LOOP OVER ENERGIES. +C + RETURN + END + SUBROUTINE IOSDRV(NNRG,NPR,ENERGY,JTOTL,JTOTU,JSTEP,TEST,NCAC, + 1 IFLS,LINE,LTYPE,MXLN,INTFLG,ITYPE,LMAX,MMAX, + 2 IPROGM,URED,LABEL,NUMDER, + 3 LAMBDA,MXLAM,NPOTL,CINT,IRMSET,IRXSET,RVFAC, + 4 DEEP,PRINT,NVC, ISAVEU,TITIME,RM,EPSIL,RMIN,RMAX) +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C INTEGRATED MOLSCAT/IOS IMPLEMENTED APR 86 CAMBRIDGE, ENGLAND. +C -- A GUTTED VERSION OF IOS1, INTERFACED TO CCP6 MOLSCAT. +C THIS IS A DRIVER FOR THE IOS CODE; MOLSCAT/DRIVER CALLS +C BASIN TO READ &BASIS, WHICH THEN CALLS IOSBIN. +C DRIVER THEN CALLS POTENL TO GET &POTL DATA, +C AND FINALLY CALLS IOSDRV TO SET UP AND PERFORM IOS CALCULATION. +C + INTEGER PRINT + DIMENSION ENERGY(NNRG),TEST(2),LINE(2,MXLN),LTYPE(MXLN), + 1 LAMBDA(MXLAM) + LOGICAL NUMDER + CHARACTER*80 LABEL +C +C LAST CHANGED 1/19/93. NEW DYNAMIC MEMORY HANDLING +C ** VERSION 6 / OCT 85/ ADDS ITYPE=6 CAPABILITY +C / ALSO ALLOWS "UNEXPANDED" POTL, V(R,ANGLES) +C ** VERSION 5 / MAR 81/ ADDS INTFLG=4 (MOLSCAT V.8) +C / JUNE 82/ REPLACES PLM WITH R. T PACK VERSION. +C ** VERSION 4 / MAY. 78/ ADDS ITYPE=5 CODE. +C / SEP. 78/ **TEMPORARY** ISAVEU CPABILITY +C / APR. 79/ CHANGED FOR ISCRU (MOLSCAT V.7) COMPATABIL +C ** VERSION 3 / DEC. 77/ IS TOTALLY NEW ORGANIZATION TO ACCOMMODATE +C ITYPE=2 (VIBROTOR - ATOM) +C ** VERSION 2 / OCT. 77/ ADDS WKB (R.T PACK) CAPABILITY ** +C ** VERSION 1 / SEP. 77/ INTERFACE HOUSTON PROGRAM W/MOLSCAT. +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C MX,IXNEXT ARE MAX AND NEXT AVAILABLE LOCATION IN X() ARRAY +C IVLFL FLAGS WHETHER IV() ARRAY IS USED AS POINTED W/ VL ARRAY. +C NIPR IS NUMBER OF INTEGERS PER REAL; SHOULD BE 1 OR 2. +C +C CMBASE MODIFIED TO MATCH CURRENT SPECS IN MOLSCAT/BASIS +C THIS IS USED ONLY TO GET LV,EV VALUES IN IOSBIN SO THEY CAN BE +C WRITTEN TO ISAVEU HERE. + DIMENSION EV(1000),LV(4000) + COMMON /CMBASE/ DUM(1016),IDUM(4031) + EQUIVALENCE (EV(1),DUM(13)),(LV(1),IDUM(2)) +C +C MUST INITIALIZE NUSED NON-NEGATIVE BEFORE CALL CHKSTR + NUSED=0 + WRITE(6,68) + 68 FORMAT('0 IOSDRV ENTERED. SET-UP FOR INFINITE ORDER SUDDEN', + 1 ' CALCULATION.') +C +C CONTINUE WITH SET-UP FOR IOS. PROCESS &POTL LAM(MXLAM) DATA +C SET NGPT, LMAX AND GAUSS PTS/WTS. +C N.B. LMAX/MMAX INITIALLY CONTAIN HIGHEST L,M VALUES +C DESIRED FOR QLM. LMAX IS RESET TO EQUAL THE *NUMBER* OF L,M +C VALUES IN LM,SLLR,SLLI,ETC. + CALL IOSBGP(MXLAM,LAMBDA,MXXXXL,NGPT,LMAX,MMAX,NQL,NIXQL) +C +C RESERVE STORAGE FOR VARIABLES. IC HAS NEXT AVAIL LOC IN X() +C STORAGE FOR SCATTERING VARIABLES . . . +C SREAL(NVC,NVC),SIMAG(NVC,NVC),WVEC(NVC),EINT(NVC),CENT(NVC), +C VL(NVC*(NVC+1)/2,MXLAM),JJJ(NVC),LORB(NVC),NB(NVC) +C --ADDED APR 86-- KMAT(NVC,NVC),IV(NVC*(NVC+1)/2,MXLAM) +C +C V11 CODE EXPECTED IC TO BE STORAGE USED SO FAR + ISVMEM=IXNEXT + IC=IXNEXT-1 + IXSR=IC+1 + IXSR=IXNEXT + IXSI=IXSR+NVC*NVC + IXKMAT=IXSI+NVC*NVC + IXWV=IXKMAT+NVC*NVC + IXEINT=IXWV+NVC + IXCENT=IXEINT+NVC + IXVL=IXCENT+NVC + NV=NVC*(NVC+1)*NPOTL/2 + IXJJJ=IXVL+NV + IXLORB=IXJJJ+NVC + IXNB=IXLORB+NVC + IXIV=IXNB+NVC + IC=IXIV + IF (IVLFL.GT.0) IC=IXIV+(NV+NIPR-1)/NIPR +C +C IOS VARIABLES +C VLI(NGPT,MXXXXL),PWGHT(NGPT,LMAX),SLR(NVC,NVC,NGPT), +C SLI(NVC,NVC,NGPT),SIGTH(NVC,NVC,NGPT),SIGAV(NVC,NVC), +C QLS(NVC,NVC),QLT(NVC,NVC,NQL),IEC(NQL ),IXQL(NIXQL,NQL) +C SLLR(NVC,NVC,LMAX),SLLI(NVC,NVC,LMAX),LM(3,LMAX) +C + IXVLI=IC + IXPW=IXVLI+MXXXXL*NGPT + IXSLR=IXPW+NGPT*LMAX + IXSLI=IXSLR+NVC*NVC*NGPT + IXSGTH=IXSLI+NVC*NVC*NGPT + IXSGAV=IXSGTH+NVC*NVC*NGPT + IXQLS=IXSGAV+NVC*NVC + IXQLT=IXQLS+NVC*NVC + IXSLLR=IXQLT+NVC*NVC*NQL + IXSLLI=IXSLLR+NVC*NVC*LMAX + IXIEC=IXSLLI+NVC*NVC*LMAX + IXQL=IXIEC+(NQL+NIPR-1)/NIPR + IXLM=IXQL+(NIXQL*NQL+NIPR-1)/NIPR + IC=IXLM+(3*LMAX+1)/NIPR + WRITE(6,681) NVC,NGPT,LMAX,MXXXXL,NQL,NIXQL,IC + 681 FORMAT('0 STORAGE ALLOCATED FOR NVC (NO. VIB. CHANNELS) =',T60, + 1 I4/25X,'NGPT (NO. GAUSS PTS.) =',T58,I6/ + 2 25X,'LMAX (NO. LEGENDRE COEFFS.) =',T60,I4/ + 3 25X,'MXXXXL (NO. SYMMETRIES IN POTL) =',T60,I4/ + 4 25X,'NQL (NO. QLT) =',T60,I4/ + 5 25X,'NIXQL (NO. INDICES IN IXQL) =',T60,I4/ + 6 25X,'NEXT LOCATION =',T54,I10) +C IC IS NOW 'NEXT STORAGE LOCATION' + IXNEXT=IC + CALL CHKSTR(NUSED) +C +C SET UP PWGHT, VLI TABLES - ALSO IXQL TABLE +C + CALL IOSB1(X(IXPW),X(IXVLI),X(IXQL),X(IXLM),NGPT,LMAX,MXXXXL, + 1 NIXQL,NQL) +C + IF (ISAVEU.LE.0) GO TO 3000 +C +C *** ISAVEU OUTPUT -- MAY 92 VERSION +C + WRITE(6,3600) ISAVEU + 3600 FORMAT('0'/'0 QLS/QLT SAVED (MAY 92 FORMAT) ON UNIT ISAVEU =',I3) + IPOUT=100+IPROGM + ITOUT=100+ITYPE-100*(ITYPE/100) + WRITE(ISAVEU,3601) LABEL,ITOUT,NVC,NQL,URED,IPOUT + 3601 FORMAT(A80/3I4,F8.4,I4) +C WRITE(ISAVEU,3602) (LV(I),I=1,NVC) + 3602 FORMAT(20I4) +C WRITE(ISAVEU,3603) NVC,(EV(I),I=1,NVC) + 3603 FORMAT(I4/(5E16.8)) +C WRITE(ISAVEU,3603) NNRG,(ENERGY(I),I=1,NNRG) +C + 3000 CALL GCLOCK(TJTIME) + TIME=TJTIME-TITIME + WRITE(6,640) TIME + 640 FORMAT('0 TIME TO SET UP CALCULATION WAS',F8.2, + 1 ' SECONDS. EXIT IOSDRV') + WRITE(6,69) + 69 FORMAT('0',30('====')) +C +C PASS CONTROL TO IOSCLC TO DO CALCULATION. +C + CALL IOSCLC(NNRG,ENERGY,JTOTL,JTOTU,JSTEP,INTFLG,PRINT,ISAVEU, + 1 ITYPE,RMIN,RMAX,DEEP,IRMSET,IRXSET,RVFAC,NUMDER, + 2 NCAC,TEST,RM,EPSIL,NVC,LMAX,NGPT,NQL,NIXQL, + 3 MXXXXL,LAMBDA,MXLAM,NPOTL,X(IXVLI), + 4 X(IXPW),X(IXSLR),X(IXSLI),X(IXQLT),X(IXQLS), + 5 X(IXSLLR),X(IXSLLI),X(IXQL), + 6 X(IXSGTH),X(IXSGAV),X(IXIEC),X(IXLM), + 7 IXSR,IXSI,IXKMAT,IXVL,IXIV,IXEINT,IXCENT,IXWV, + 8 IXJJJ,IXLORB,IXNB,X(IXWV),X(IXNB), + 9 IFLS,MXLN,LINE,LTYPE) +C +C RELEAST STORAGE USED BY IOSDRV/IOSCLC/STORAG + IXNEXT=ISVMEM + RETURN + END + SUBROUTINE IOSOUT(ENERGY,QL,QLOLD,NVC,ITYPE,ATAU,LM,IXQL, + 1 LMAX,NIXQL,NQL,JSTEP) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C>>SG MODIFIED MAY 92 - ITYPE=3 / ADD JSTEP TO PARAMETER LIST. +C>>SG MODIFIED FEB 92 +C>>SG TO CORRECT APPARENT COMPILER BUG, IN FORMATS 615,616 +C>>SG TO ALLOW FOR OUTPUT OF NOUT.LT.NVC VIB LEVELS IF SOME CLOSED +C +C AUG 86 IXQLF ADD LM,LMAX ARGUMENTS +C *** TO CONTROL OPTIONAL 'DEBUGGING' OUTPUT *** + LOGICAL PRNT +C ALLOW FOR MXSIG OUTPUT LEVELS + PARAMETER (MXSIG=200) + CHARACTER*1 S(MXSIG),BLANK,STAR + CHARACTER*4 LCODE(3),LQLT,LQLS + DIMENSION QL(NVC,NVC,NQL),QLOLD(NVC,NVC) + DIMENSION LM(3,LMAX),IXQL(NIXQL,NQL) + DIMENSION ATAU(2) +C STORAGE RESERVED FOR MAXIMUM OF MXSIG LEVELS + DIMENSION SIG(MXSIG),SIG3(MXSIG) +C +C COMMON BLOCKS TO COMMUNICATE WITH IOSBIN(BASIS SET) ROUTINES + COMMON /CMBASE/DUM(1016),IDUM(4031) + DIMENSION JLEV(4000) + EQUIVALENCE (NLEV,IDUM(1)), (JLEV(1),IDUM(2)), (IDENT,IDUM(4029)) + COMMON /IOUTCM/ JMAX,LEVV(4000) +C COMMON TO GET SYMMETRY INFORMATION (IHOMO1,IHOMO2) FOR ITYPE=3 + COMMON/ANGLES/COSANG(7),FACTOR,IH1,IH2,IH3,IH4 +C + DATA IZERO/0/, ZTOL/1.D-8/ + DATA BLANK/' '/, STAR/'*'/ + DATA LCODE/' ','REAL','IMAG'/, LQLT/' QLT'/, LQLS/' QLS'/ + DATA PRNT/.FALSE./ +C +C STATEMENT FUNCTION FOR NORMALIZATION XNORM . . . + XNORM(EPSI)=1.D0/(1.D0+ABS(EPSI)) + FUNC(I)=2.D0*DBLE(I)+1.D0 +C + WRITE(6,601) ENERGY + 601 FORMAT('1 STATE-TO-STATE CROSS SECTIONS (IN ANG**2) FOR KINETIC ', + & 'ENERGY =',F12.4,' (1/CM).'/'0 PROCESSED BY IOSOUT (FEB 92).') +C + XJSTEP=JSTEP + IF(JSTEP.GT.1) WRITE(6,690) JSTEP + 690 FORMAT('0 CROSS SECTIONS (BUT NOT QL) MULTIPLIED BY JSTEP =' + 1 ,I3) + IF (ITYPE.EQ.5 .OR.ITYPE.EQ.6) GO TO 5000 + IF (ITYPE.EQ.3) GO TO 3000 +C +C CODE BELOW IS ITYPE=1,2 FROM VERSION 3. IT SHOULD STILL WORK +C SINCE ALL QL (NOW QLT) ARE IN ORDER. + WRITE(6,610) NVC,(LEVV(I),I=1,NVC) + 610 FORMAT('0 NO. OF VIBRATIONAL LEVELS =',I4,'. LEVELS ARE'/ + & (' ',13I10) ) + IF (JMAX.LT.MXSIG) GO TO 2200 + WRITE(6,692) JMAX,MXSIG + 692 FORMAT('0 JMAX =',I6,' REDUCED BECAUSE OF MXSIG =',I5) + JMAX=MXSIG-1 + 2200 WRITE(6,602) JMAX + 602 FORMAT('0 MAXIMUM J-VALUE REQUESTED IS',I4) +C>>SG ------------------------- >> CODE BELOW ADDED FEB 92 +C>> DETERMINE IF ALL CHANNELS ARE OPEN. SINCE WE DON'T HAVE ACCESS +C TO NOPEN HERE, SIMPLY FIND THE HIGHEST 'CHANNEL' FOR WHICH WE +C HAVE NONZERO QL() OR QLOLD() + NOUT=0 + DO 2300 IV=1,NVC +C FIRST CHECK QLOLD + DO 2301 IVP=1,NVC + IF (QLOLD(IV,IVP).NE.0.) GO TO 2390 + 2301 CONTINUE +C THEN CHECK QL() + DO 2302 IVP=1,NVC + DO 2302 IL=1,NQL + IF (QL(IV,IVP,IL).NE.0.) GO TO 2390 + 2302 CONTINUE + GO TO 2300 + 2390 NOUT=IV + 2300 CONTINUE + IF (NOUT.NE.NVC) WRITE(6,620) NOUT + 620 FORMAT('0 IOSOUT (FEB 92). ALL QL,QLOLD ZERO FOR SOME CHANNELS' + 1 ,', PRESUMABLY CLOSED ENERGETICALLY.'/ + 2 '0 OUTPUT LIMITED TO NOUT =',I3) +C +C<>SG ITYPE=3 CODE ADDED MAY 92. ASSUMES NVC=1 (ONE VIB CHANNEL) + 3000 WRITE(6,630) + 630 FORMAT('0'/'0 ACCUMULATED Q(L1,L2,L) ARE AS FOLLOWS') + WRITE(6,651) LCODE(1),LQLS,LM(1,1),LM(2,1),LM(3,1),QLOLD(1,1) + DO 3001 L=1,NQL + 3001 WRITE(6,651) LCODE(1),LQLT,LM(1,L),LM(2,L),LM(3,L),QL(1,1,L) + IF (LM(1,1).EQ.0.AND.LM(2,1).EQ.0.AND.LM(3,1).EQ.0) GO TO 3002 + WRITE(6,639) + 639 FORMAT(' IOSOUT *** ERROR. L1=L2=L=0 IS NOT FIRST SYMMETRY IN LM') + 3002 L1MAX=0 + L2MAX=0 + DO 3003 IL=1,LMAX + L1MAX=MAX0(L1MAX,LM(1,IL)) + 3003 L2MAX=MAX0(L2MAX,LM(2,IL)) + NL2=L2MAX/IH2+1 + IX=0 + DO 3100 L1=0,L1MAX,IH1 + LTOP=L2MAX + IF (IDENT.GT.0) LTOP=L1 + DO 3100 L2=0,LTOP,IH2 + IX=IX+1 + NSIG=IX + IF (NSIG.LE.MXSIG) GO TO 3109 + WRITE(6,638) MXSIG + 638 FORMAT(' *** ERROR. MXSIG (DIMENSION OF SIG3) EXCEEDED',I5) + STOP + 3109 SIG3(IX)=0. + LLO=ABS(L1-L2) + LHI=L1+L2 + DO 3102 LL=LLO,LHI,2 +C SEARCH LM(,IL) FOR L1,L2,LL + DO 3101 IL=1,LMAX + IF (L1.NE.LM(1,IL).OR.L2.NE.LM(2,IL).OR.LL.NE.LM(3,IL)) GO TO 3101 + SIG3(IX)=SIG3(IX)+QL(1,1,IL) * XJSTEP + GO TO 3102 + 3101 CONTINUE + WRITE(6,631) L1,L2,LL + 631 FORMAT(' IOSOUT *** ERROR. REQUIRED QL(',3I3,') NOT FOUND.') + 3102 CONTINUE + 3100 WRITE(6,632) L1,L2,SIG3(IX) + 632 FORMAT(' SIG( 0 0 ->',2I3,') =',F10.3,' ANG**2') +C + IF (NLEV.LE.0) RETURN + WRITE(6,633) (I,JLEV(2*I-1),JLEV(2*I),I=1,NLEV) + 633 FORMAT('0'/'0 CROSS SECTIONS WILL BE COMPUTED AMONG FOLLOWING ', + & 'LEVELS'/'0 LEVEL J1 J2 '/(' ',3I4)) + IF (NLEV.GT.MXSIG) THEN + WRITE(6,693) NLEV,MXSIG + NLEV=MXSIG + ENDIF + IMSG=0 + DO 3200 I=1,NLEV + JI1=JLEV(2*I-1) + JI2=JLEV(2*I) + WRITE(6,634) I,JI1,JI2 + 634 FORMAT('0 INITIAL LEVEL =',I4,' J1, J2 =',3I4) + DO 3201 IF=1,NLEV + JF1=JLEV(2*IF-1) + JF2=JLEV(2*IF) + SIG(IF)=0. + S(IF)=BLANK +C IF (IF.EQ.I) GO TO 3200 + L1LO=ABS(JI1-JF1) + L1HI=JI1+JF1 + L2LO=ABS(JI2-JF2) + L2HI=JI2+JF2 + DO 3202 L1=L1LO,L1HI,IH1 + IX1=L1/IH1+1 + DO 3202 L2=L2LO,L2HI,IH2 + IX2=L2/IH2+1 + IF (IDENT.NE.0) GO TO 3203 +C INDEX FOR DISTINGUISHABLE PARTICLES + IX=(IX1-1)*NL2+IX2 + GO TO 3204 +C BELOW FOR INDISTINGUISHABLE PARTICLES/ ASSUME IH2=IH1. + 3203 IX1=MAX0(L1,L2)/IH1+1 + IX2=MIN0(L1,L2)/IH1+1 + IX=(IX1-1)*IX1/2+IX2 +C SEE IF WE HAVE THIS (I.E., IX.LE.NSIG) + 3204 IF (IX.LE.NSIG) GO TO 3205 + S(IF)=STAR + IMSG=1 + GO TO 3202 + 3205 TJ1=THREEJ(JI1,L1,JF1) + TJ2=THREEJ(JI2,L2,JF2) + SIG(IF)=SIG(IF)+TJ1*TJ1*TJ2*TJ2*SIG3(IX) + 3202 CONTINUE + 3201 SIG(IF)=SIG(IF)*(2*JF1+1)*(2*JF2+1) + 3200 WRITE(6,604) (IF,SIG(IF),S(IF),IF=1,NLEV) + IF (IMSG.GT.0) WRITE(6,699) + RETURN +C +C BELOW FOR ITYPE=5, INITIAL PROCESSING FOR ITYPE=6 ALSO +C>>SG (FEB 92) N.B. CODE *ASSUMES* NVC=1 (ONE VIB CHANNEL). + 5000 WRITE(6,650) + 650 FORMAT('0'/'0 ACCUMULATED Q(L,M1,M2) ARE AS FOLLOWS') + WRITE(6,651) LCODE(1),LQLS,IZERO,IZERO,IZERO,QLOLD(1,1) + 651 FORMAT(' ',A4,2X,A4,'(',3I3,') =',1PE13.5) + DO 5001 L=1,NQL + 5001 WRITE(6,651) LCODE(IXQL(NIXQL,L)+1),LQLT,LM(1,IXQL(1,L)), + & LM(2,IXQL(1,L)),LM(2,IXQL(2,L)),QL(1,1,L) + IMSG=0 + IF (NLEV.LE.MXSIG) GO TO 5109 + WRITE(6,693) NLEV,MXSIG + 693 FORMAT('0 NLEV =',I6,' REDUCED BECAUSE OF MXSIG =',I5) + NLEV=MXSIG + 5109 IF (ITYPE.EQ.6) GO TO 6000 + WRITE(6,652) + 652 FORMAT('0'/'0 CROSS SECTIONS WILL BE COMPUTED AMONG FOLLOWING ', + & 'LEVELS'/'0 LEVEL J K PRTY') + DO 5002 I=1,NLEV + 5002 WRITE(6,653) I,JLEV(3*I-2),JLEV(3*I-1),JLEV(3*I) + 653 FORMAT(' ',4I4) + DO 5100 I=1,NLEV + JI=JLEV(3*I-2) + XJI=JI + KI=JLEV(3*I-1) + XKI=KI + EPSI=PARITY3(JLEV(3*I)) + IF (KI.EQ.0) EPSI=0.D0 + XNI=XNORM(EPSI) + WRITE(6,654) I,JI,KI,JLEV(3*I) + 654 FORMAT('0 INITIAL LEVEL =',I4,' J, K, PRTY =',3I4) + DO 5101 IF=1,NLEV + JF=JLEV(3*IF-2) + XJF=JF + KF=JLEV(3*IF-1) + XKF=KF + EPSF=PARITY3(JLEV(3*IF)) + IF (KF.EQ.0) EPSF=0.D0 + XNF=XNORM(EPSF) + LLO=IABS(JI-JF) + LHI=JI+JF + PJK=PARITY3(JI+JF+KI+KF) + MPLS=KI+KF + MMIN=IABS(KI-KF) + P2=1.D0 + IF (KI-KF.LT.0) P2=PARITY3(MMIN) + SIG(IF)=0.D0 + S(IF)=BLANK + TMAX=0.D0 + DO 5102 L=LLO,LHI + XL=L + PL=PJK*PARITY3(L) +C -----------------------TERM 1 ------------------- + PP=1.D0+EPSI*EPSF*PL + PP=PP*PP + IF (PP.LE.ZTOL) GO TO 5200 + TJ=THRJ(XJF,XL,XJI,XKF,XKI-XKF,-XKI) + TJ=TJ*TJ + IF (TJ.LE.ZTOL) GO TO 5200 + CALL IXQLF(LM,LMAX,L,MMIN,MMIN,0,INDEX,IXQL,NIXQL,NQL) + IF (INDEX.GT.0) GO TO 5110 + IF (INDEX.EQ.-1) GO TO 5200 + IMSG=1 + S(IF)=STAR +C IF ('PRINT'.GT.25) WRITE(6, ) MSG + GO TO 5200 + 5110 TT=PP*TJ*QL(1,1,INDEX) + TMAX=MAX(ABS(TT),TMAX) + SIG(IF)=SIG(IF)+TT * XJSTEP +C -----------------------TERM 2 ------------------- + 5200 PP=(1.D0+EPSI*EPSF*PL)*(EPSF+EPSI*PL) + IF (ABS(PP).LE.ZTOL) GO TO 5300 + TJ=THRJ(XJF,XL,XJI,XKF,XKI-XKF,-XKI)* + & THRJ(XJF,XL,XJI,-XKF,XKF+XKI,-XKI) + IF (ABS(TJ).LE.ZTOL) GO TO 5300 + CALL IXQLF(LM,LMAX,L,MPLS,MMIN,1,INDEX,IXQL,NIXQL,NQL) + IF (INDEX.GT.0) GO TO 5210 + IF (INDEX.EQ.-1) GO TO 5300 + IMSG=1 + S(IF)=STAR +C ON HIGH PRNTLV WRITE MSG + GO TO 5300 + 5210 TT=2.D0*P2*PP*TJ*QL(1,1,INDEX) + TMAX=MAX(TMAX,ABS(TT)) + SIG(IF)=SIG(IF)+TT * XJSTEP +C -----------------------TERM 3 ------------------- + 5300 PP=EPSF+EPSI*PL + PP=PP*PP + IF (PP.LE.ZTOL) GO TO 5102 + TJ=THRJ(XJF,XL,XJI,-XKF,XKF+XKI,-XKI) + TJ=TJ*TJ + IF (TJ.LE.ZTOL) GO TO 5102 + CALL IXQLF(LM,LMAX,L,MPLS,MPLS,0,INDEX,IXQL,NIXQL,NQL) + IF (INDEX.GT.0) GO TO 5310 + IF (INDEX.EQ.-1) GO TO 5102 + S(IF)=STAR + IMSG=1 +C ON 'PRNTLV' WRITEN MSG + GO TO 5102 + 5310 TT=PP*TJ*QL(1,1,INDEX) + TMAX=MAX(ABS(TT),TMAX) + SIG(IF)=SIG(IF)+TT * XJSTEP + 5102 CONTINUE + IF (ABS(SIG(IF)).GE.ZTOL*TMAX) GO TO 5101 + IF (SIG(IF).EQ.0.D0) GO TO 5101 + IF (PRNT) WRITE(6,697) IF,SIG(IF),TMAX + 697 FORMAT(' * * * NOTE. ROUND-OFF ERROR FOR LEV(F) =',I3, + & ', SIG(IF),TMAX =',2D12.4) + SIG(IF)=0.D0 + 5101 SIG(IF)=SIG(IF)*XNI*XNF*FUNC(JF) + 5100 WRITE(6,604) (IF,SIG(IF),S(IF),IF=1,NLEV) + IF (IMSG.GT.0) WRITE(6,699) + RETURN +C +C BELOW FOR ITYPE=6 + 6000 DO 6100 I=1,NLEV + WRITE(6,664) I,JLEV(4*I-3),JLEV(4*I-2),JLEV(4*I-1) + 664 FORMAT('0 INITIAL LEVEL =',I4,' J, TAU, PARITY =',3I4) + DO 6101 IF=1,NLEV + SIG(IF)=0.D0 + S(IF)=BLANK + 6101 CALL SIG6(NLEV,JLEV,ATAU,I,IF,SIG(IF),S(IF),IMSG,QL,IXQL,NIXQL, + 1 NQL,LM,LMAX) + 6100 WRITE(6,604) (IF,SIG(IF)*XJSTEP,S(IF),IF=1,NLEV) + IF (IMSG.GT.0) WRITE(6,699) + RETURN +C + END + SUBROUTINE IOSPB(ENERGY,QL,QLOLD,NL,LINE,LTYPE,ITYPE, + 1 NVC,LM,IXQL,LMAX,NIXQL,NQL) +C *** +C *** MODIFIED DEC 86 FOR COMPATBILITY WITH OFF-DIAGONAL PRBR CODE +C *** +C ** N.B. DIMENSIONS ON QL,QLOLD SHOULD HAVE NVC REMOVED. +C ALSO, LM APPEARS NOT TO BE USED IN THIS ROUTINE +C AUG 86 IXQLF ADD LM,LMAX ARGUMENTS +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + LOGICAL EXISTS +C TO CONTROL PRINTING OF 'OPTIONAL' OUTPUT + LOGICAL LPRT +C FOR UPWARD COMPATIBILITY WITH OLD (DIAG ONLY) INPUT + LOGICAL LDIAG +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +C DEC 86 LINE() CHANGED TO 1-DIMENSIONAL ARRAY CONTROLED BY NPL + DIMENSION QL(NVC,NVC,NQL),QLOLD(NVC,NVC),LINE(2),LTYPE(NL) + DIMENSION LM(3,LMAX),IXQL(NIXQL,NQL) +C QLOLD IS QL(0) IN THE NOTATION OF IOS PAPER 1. +C +C COMMON TO COMMUNICATE WITH IOSBIN ROUTINE + DIMENSION JLEV(4000) + COMMON /CMBASE/DUM(1016),IDUM(4031) + EQUIVALENCE (JLEV(1),IDUM(2)), (NLEV,IDUM(1)) +C + DATA IZERO/0/, IONE/1/, TOL/1.D-5/ + DATA LPRT/.FALSE./ + DATA LDIAG/.FALSE./ +C +C STATEMENT FUNCTION DEFINITIONS. . . + XNORM(EPSA)=1.D0/(1.D0+ABS(EPSA)) + FUNC(JA)=DBLE(2*JA+1) + EXISTS(I)= I.GT.0 .AND. I.LE.NLEV +C + IF (NL.LE.0) RETURN +C NPL IS NO. OF INDICES IN LINE PER CROSS SECTION + NPL=4 + IF (LDIAG) NPL=2 + WRITE(6,600) NL,ENERGY + 600 FORMAT('0'/'0 PRESSURE BROADENING CROSS SECTIONS REQUESTED FOR', + & I4,' SPECTRAL LINES.'/'0 ENERGY =',F12.4,' (1/CM).') + IF (ITYPE.EQ.1 .AND. NVC.EQ.1) GO TO 1111 + IF (ITYPE.EQ.5 .AND. NVC.EQ.1) GO TO 5000 + WRITE(6,695) ITYPE,NVC + 695 FORMAT('0 * * * NOTE. IOSPB NOT SUPPORTED FOR ITYPE, NVC =',2I6) + NL=0 + RETURN + 1111 QTOT=0D0 + IF (LMAX.LT.2) GO TO 1001 + DO 1000 IL=2,LMAX + 1000 QTOT=QTOT+QL(1,1,IL) + 1001 LM1=LMAX-1 + WRITE(6,651) LM1,QTOT,QLOLD(1,1) + 651 FORMAT('0 SUM OVER Q(L), L = 1,',I3,' =',F12.4,' QLOLD(0) =', + & F12.4) +C *** +C *** SAVE QL(1,1,1) AND REPLACE WITH QLOLD(1,1) + Q0SAVE=QL(1,1,1) + QL(1,1,1)=QLOLD(1,1) +C *** LOOP OVER LINES + DO 2000 LN=1,NL + LVA=LINE((LN-1)*NPL+1) + LVB=LINE((LN-1)*NPL+2) + IF (.NOT.LDIAG) GO TO 1091 + LVA1=LVA + LVB1=LVB + GO TO 1092 + 1091 LVA1=LINE((LN-1)*NPL+3) + LVB1=LINE((LN-1)*NPL+4) + 1092 IF (EXISTS(LVA).AND.EXISTS(LVB).AND.EXISTS(LVA1).AND.EXISTS(LVB1)) + 1 GO TO 2001 + WRITE(6,691) LN,LVA,LVB,LVA1,LVB1 + 691 FORMAT('0 * * * ERROR. FOR LINE',I3,' LEVEL A OR B .GT. NLEV - + & CANNOT PROCESS',4I6) + GO TO 2000 + 2001 JA=JLEV(LVA) + JB=JLEV(LVB) + JA1=JLEV(LVA1) + JB1=JLEV(LVB1) + K=LTYPE(LN) + IF (K.LE.0) K=IABS(JA-JB) + WRITE(6,601) LN,JA,JB,JA1,JB1,K + 601 FORMAT('0 LINE',I3,' FOR JA, JB; JA1, JB1 = ',2I4,4X,2I4, + & ' PROCESSED FOR',I4,'-POLE RADIATION.') + LTOP=MIN0(JA+JA1,JB+JB1) + IF (LTOP.LE.LM1) GO TO 2002 + WRITE(6,692) LTOP,LM1 + 692 FORMAT('0 * * * WARNING. POSSIBLE ERROR LTOP.GT.LMAX',2I6) + LTOP=LM1 + 2002 LMIN=MAX0(IABS(JA-JA1),IABS(JB-JB1)) + QTOT2=0. + DO 2100 L=LMIN,LTOP +C FC=FCOEF(JA,JB,JA,JB,K,L) + FC=PARITY3(K)*FUNC(JA1)*DSQRT(FUNC(JB1)*FUNC(JB))* + 1 THREEJ(JA,JA1,L)*THREEJ(JB,JB1,L)*SIXJ(JA,JB,JA1,JB1,K,L) + TERM=FC*QL(1,1,L+1) + 2100 QTOT2=QTOT2-TERM + WRITE(6,602) QTOT2 + 602 FORMAT(11X,'***** PRESSURE BROADENING CROSS SECTION =',F12.4, + & ' ANG**2 *****') + 2000 CONTINUE +C RESTORE QL(1,1,1) + QL(1,1,1)=Q0SAVE + RETURN +C ***** ITYPE = 5 ***** +C Q(L,MA,MB) ACCESSED VIA IXQLF WHICH RETURNS INDEX IN QL. +C -1 RETURNED IF MISSING BY SYMMETRY RESTRICTION / 0 IF NOT FOUND +C FOLLOWING ASSUMED ABOUT TABLE. +C MA.GE.MB IN TABLE / TO REVERSE ORDER TAKE COMPLEX CONJUGATE +C IMAGINARY PART FOR L,MA,MB ASSUMED TO FOLLOW REAL PART IN TABLE. +C IF KA (KB) .NE. 0 THEN TERMS 2 (3) AND 4 WILL NOT BE PROCESSED. +C + 5000 IF (LDIAG) GO TO 5901 + WRITE(6,699) + 699 FORMAT('0 *** NEW IOSPB NOT SUPPORTED FOR ITYPE=5 AND .NOT.LDIAG' + 1 ,' --- REQUEST CANCELED.') + RETURN + 5901 DO 5001 LN=1,NL + LVA=LINE((LN-1)*NPL+1) + LVB=LINE((LN-1)*NPL+2) + IF (EXISTS(LVA).AND.EXISTS(LVB)) GO TO 5002 + WRITE(6,691) LN,LVA,LVB + GO TO 5001 + 5002 JA=JLEV(3*LVA-2) + KA=JLEV(3*LVA-1) + EPSA=PARITY3(JLEV(3*LVA)) + IF (KA.EQ.0) EPSA=0.D0 + XJA=JA + XKA=KA + KA2=2*KA + JB=JLEV(3*LVB-2) + KB=JLEV(3*LVB-1) + EPSB=PARITY3(JLEV(3*LVB)) + IF (KB.EQ.0) EPSB=0.D0 + XJB=JB + XKB=KB + KB2=2*KB + K=LTYPE(LN) + IF (K.LE.0) K=IABS(JA-JB) + WRITE(6,652) LN,LVA,LVB,JA,KA,EPSA,JB,KB,EPSB,K + 652 FORMAT('0 LINE',I3,' BETWEEN LEVEL',2I4,5X,'(J, K, EPS =',2I4,F5.1 + & ,' TO',2I4,F5.1,') PROCESSED FOR', + 2 I4,'-POLE RADIATION.') + LTOP=2*MIN0(JA,JB) + QTOT2=0.D0 + QTOTI=0.D0 + FACT=-XNORM(EPSA)*XNORM(EPSB)*PARITY3(K+KA+KB)*FUNC(JA)*FUNC(JB) + DO 5100 L=IZERO,LTOP,2 + SFACT=SIXJ(JA,JB,JA,JB,K,L) + IF (ABS(SFACT).LT.TOL) GO TO 5100 + XL=L +C TERM 1 . . . + PF=(1.D0+EPSA*EPSA)*(1.D0+EPSB*EPSB) + TF=THRJ(XJA,XL,XJA,XKA,0D0,-XKA)*THRJ(XJB,XL,XJB,XKB,0D0,-XKB) +C HANDLE Q(0,0,0) -- I.E. QLOLD -- SEPARATELY. + IF (L.EQ.0) GO TO 5101 + CALL IXQLF(LM,LMAX,L,IZERO,IZERO,IZERO,IX,IXQL,NIXQL,NQL) + IF (IX.EQ.0) WRITE(6,659) L,IZERO,IZERO,IZERO + 659 FORMAT(' REQUESTED MISSING Q. L, MA, MB, CODE =',4I4) + IF (IX.LE.0) GO TO 5200 + XXX=FACT*SFACT*PF*TF + ADDR=XXX*QL(1,1,IX) + QTOT2=QTOT2+ADDR + ADDI=0.D0 + IF(LPRT)WRITE(6,657)L,IZERO,IZERO,XXX,ADDR,ADDI,QTOT2,QTOTI + 657 FORMAT(' L, MA, MB =',3I3,' *', F12.5 ,' ADD(R/I) =',2F12.5, + & ' = ',2F12.5) + GO TO 5200 + 5101 ADDI=0.D0 + XXX=FACT*SFACT*PF*TF + ADDR=XXX*QLOLD(1,1) + QTOT2=QTOT2+ADDR + IF(LPRT)WRITE(6,657)L,IZERO,IZERO,XXX,ADDR,ADDI,QTOT2,QTOTI +C TERM 2 . . . + 5200 IF (EPSA.EQ.0.D0 .OR. KA2.GT.L) GO TO 5300 + PF=2.D0*EPSA*(1.D0+EPSB*EPSB) + TF=THRJ(XJA,XL,XJA,-XKA,2.D0*XKA,-XKA)* + & THRJ(XJB,XL,XJB,XKB,0D0,-XKB) + CALL IXQLF(LM,LMAX,L,KA2,IZERO,IONE,IX,IXQL,NIXQL,NQL) + IF (IX.EQ.0) WRITE(6,659) L,KA2,IZERO,IONE + IF (IX.LE.0) GO TO 5300 + XXX=FACT*SFACT*PF*TF + ADDR=XXX*QL(1,1,IX) + ADDI=XXX*QL(1,1,IX+1) + QTOT2=QTOT2+ADDR + QTOTI=QTOTI+ADDI + IF (LPRT)WRITE(6,657)L,KA2,IZERO,XXX,ADDR,ADDI,QTOT2,QTOTI +C TERM 3 . . . + 5300 IF (EPSB.EQ.0.D0 .OR. KB2.GT.L) GO TO 5400 + PF=2.D0*EPSB*(1.D0+EPSA*EPSA) + TF=THRJ(XJA,XL,XJA,XKA,0D0,-XKA)* + & THRJ(XJB,XL,XJB,-XKB,2.D0*XKB,-XKB) + CALL IXQLF(LM,LMAX,L,KB2,IZERO,IONE,IX,IXQL,NIXQL,NQL) + IF (IX.EQ.0) WRITE(6,659) L,IZERO,KB2,IONE + IF (IX.LE.0) GO TO 5400 + XXX=FACT*SFACT*PF*TF + ADDR=XXX*QL(1,1,IX) + ADDI=-XXX*QL(1,1,IX+1) + QTOT2=QTOT2+ADDR + QTOTI=QTOTI+ADDI + IF(LPRT) WRITE(6,657) L,IZERO,KB2,XXX,ADDR,ADDI,QTOT2,QTOTI +C TERM 4 . . . + 5400 IF (EPSA*EPSB.EQ.0.D0 .OR. KA2.GT.L .OR. KB2.GT.L) GO TO 5100 + PF=4.D0*EPSA*EPSB + TF=THRJ(XJA,XL,XJA,-XKA,2.D0*XKA,-XKA)* + & THRJ(XJB,XL,XJB,-XKB,2.D0*XKB,-XKB) + IF (KA2-KB2) 5401,5402,5403 + 5401 CALL IXQLF(LM,LMAX,L,KA2,KB2,IONE,IX,IXQL,NIXQL,NQL) + IF (IX.EQ.0) WRITE(6,659) L,KA2,KB2,IONE + IF (IX.LE.0) GO TO 5100 + XXX=FACT*SFACT*PF*TF + ADDR=XXX*QL(1,1,IX) + ADDI=XXX*QL(1,1,IX+1) + QTOT2=QTOT2+ADDR + QTOTI=QTOTI+ADDI + IF (LPRT) WRITE(6,657)L,KA2,KB2,XXX,ADDR,ADDI,QTOT2,QTOTI + GO TO 5100 + 5402 CALL IXQLF(LM,LMAX,L,KA2,KB2,IZERO,IX,IXQL,NIXQL,NQL) + IF (IX.EQ.0) WRITE(6,659) L,KA2,KB2,IZERO + IF (IX.LE.0) GO TO 5100 + XXX=FACT*SFACT*PF*TF + ADDR=XXX*QL(1,1,IX) + QTOT2=QTOT2+ADDR + ADDI=0.D0 + IF (LPRT) WRITE(6,657)L,KA2,KB2,XXX,ADDR,ADDI,QTOT2,QTOTI + GO TO 5100 + 5403 CALL IXQLF(LM,LMAX,L,KB2,KA2,IONE,IX,IXQL,NIXQL,NQL) + IF (IX.EQ.0) WRITE(6,659) L,KB2,KA2,IONE + IF (IX.LE.0) GO TO 5100 + XXX=FACT*SFACT*PF*TF + ADDR=XXX*QL(1,1,IX) + ADDI=-XXX*QL(1,1,IX+1) + QTOT2=QTOT2+ADDR + QTOTI=QTOTI+ADDI + IF (LPRT) WRITE(6,657)L,KA2,KB2,XXX,ADDR,ADDI,QTOT2,QTOTI + 5100 CONTINUE + WRITE(6,658) QTOT2,QTOTI + 658 FORMAT(11X,'***** CROSS SECTION (A**2), REAL PART =',F12.4,5X, + & 'IMAG. PART =',F12.4) + 5001 CONTINUE +C + RETURN + END + FUNCTION IPASYM(JI,NK,A) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C ROUTINE TO SET PARITY CODE FOR ASYMMETRIC TOP FUNCTIONS. +C +C IPASYM K-PAR +/- PAR +C 0 EVEN + +C 1 EVEN - +C 2 ODD + +C 3 ODD - +C + DIMENSION A(NK) + DATA EPS/1.D-4/ +C + IPAR=-1 + KPAR=-1 + IF (NK.EQ.2*JI+1) GO TO 1000 + 1999 WRITE(6,699) JI,NK,(A(I),I=1,NK) + 699 FORMAT('0 * * * ERROR. FOLLOWING SET OF ASYMMETRIC TOP COEFFICIEN + &TS ARE INVALID (PARITY).',2I6/(10X,6F12.8)) + IPASYM=-1 + RETURN +C NORMALIZE IF NECESSARY . . . + 1000 XN=0.D0 + DO 1100 I=1,NK + 1100 XN=XN+A(I)*A(I) + IF (ABS(XN).GE.EPS) GO TO 1200 + WRITE(6,602) + 602 FORMAT('0 * * * ERROR. COEFFICIENTS CANNOT BE NORMALIZED.') + GO TO 1999 + 1200 XN=1.D0/SQRT(XN) + IF (ABS(XN-1.D0).LE.EPS) GO TO 2000 + WRITE(6,601) XN + 601 FORMAT(10X,'COEFFICIENTS NORMALIZED WITH FACTOR',D14.6) + 2000 DO 2100 I=1,NK + 2100 A(I)=A(I)*XN +C + NMID=JI+1 +C DETERMINE EVEN/ODD K + LP=0 + IF (ABS(A(NMID)).LE.EPS) GO TO 3100 + KPAR=0 + 3100 IF (JI.LE.0) GO TO 4000 + DO 3200 I=1,JI + LP=IABS(LP-1) + IF (ABS(A(NMID+I)).LE.EPS .AND. ABS(A(NMID-I)).LE.EPS) + & GO TO 3200 + IF (KPAR.GE.0) GO TO 3300 + KPAR=LP + GO TO 3200 + 3300 IF (KPAR.EQ.LP) GO TO 3200 + KPAR=-1 + GO TO 1999 + 3200 CONTINUE +C +C NOW DO +/- KPARITY . . . + 4000 IF (ABS(A(NMID)).LE.EPS) GO TO 4100 + IPAR=0 + 4100 IF (JI.LE.0) GO TO 5000 + DO 4200 I=1,JI + IF (ABS(A(NMID-I)).GT.EPS) GO TO 4300 + IF (ABS(A(NMID+I)).LE.EPS) GO TO 4200 + IPAR=-1 + GO TO 1999 + 4300 RATIO=A(NMID+I)/A(NMID-I) + IF (ABS(RATIO-1.D0).LE.EPS) GO TO 4400 + IF (ABS(RATIO+1.D0).LE.EPS) GO TO 4500 + IPAR=-1 + GO TO 1999 + 4500 IF (IPAR) 4501,4502,4200 + 4501 IPAR=1 + GO TO 4200 + 4502 IPAR=-1 + GO TO 1999 + 4400 IF (IPAR) 4401,4200,4402 + 4401 IPAR=0 + GO TO 4200 + 4402 IPAR=-1 + GO TO 1999 + 4200 CONTINUE +C + 5000 IF (KPAR.LT.0 .OR. IPAR.LT.0) GO TO 1999 + IPASYM=2*KPAR+IPAR + RETURN + END + SUBROUTINE ISUTP(ISU,EN,JTL,JST,JT,NVC,NQL,QLS,QLT) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION QLS(NVC,NVC),QLT(NVC,NVC,NQL) + IF (ISU.LE.0) RETURN + WRITE(ISU,3232) EN,JTL,JST,JT + 3232 FORMAT(' ENERGY',F10.3,' JTOT',3I6) + WRITE(ISU,3233) ((QLS(IV,IVP),IV=1,NVC),IVP=1,NVC) + 3233 FORMAT(1P,5D16.8) + WRITE(ISU,3233) (((QLT(IV,IVP,L),IV=1,NVC),IVP=1,NVC),L=1,NQL) + RETURN + END + SUBROUTINE IVCHK(IVLFL,IPRINT,ITYPE,NLABV,MXLAM,NPOTL,LAM) + DIMENSION LAM(1),NLABV(9) +C +C THIS ROUTINE CHECKS LAMBDA (MOLSCAT POTENTIAL SYMMETRY INDICES) +C TO ASCERTAIN WHETHER IV() INDEXING SCHEME ('NON-TRIVIAL' CASES) +C WILL WORK. IMPLEMENTATION BEGINNING V9 WILL **NOT** WORK +C PROPERLY IF TWO OF THE 'SYMMETRIES' ARE IDENTICAL. +C +C SINCE WE HAVE ACCESS TO ITYPE/NPOTL, WE COULD ALSO CHECK WHETHER +C NPOTL IS BIG ENOUGH; NOT DONE IN CURRENT CODE. +C + LOGICAL OKEY,LTEST +C +C CALLED FROM DRIVER AFTER BASIN(IOSBIN)/POTENL(INITIZATION) +C + IF (IVLFL.LE.0) THEN + IF (IPRINT.GE.3) + 1 WRITE(6,*) ' IVCHK. IV() INDEXING IS NOT REQUESTED.' + RETURN + ENDIF + IF (MXLAM.LE.1) THEN + IF (IPRINT.GE.3) WRITE(6,*) ' IVCHK. NOT NEEDED, MXLAM.LE.1 ' + RETURN + ENDIF +C + ITP=ITYPE-10*(ITYPE/10) + IF (ITP.EQ.0) THEN + WRITE(6,*) ' *** IVCHK. ILLEGAL ITYPE',ITYPE + STOP + ENDIF + NQ=NLABV(ITP) + OKEY=.TRUE. + DO 1000 I1=2,MXLAM + ITOP=I1-1 + DO 1000 I2=1,ITOP +C LTEST IS TRUE IF LAM(,I1) IDENTICAL TO LAM(,I2) +C FALSE IF ANY INDICES DIFFER + LTEST=.TRUE. + DO 1100 N=1,NQ + 1100 LTEST=LTEST.AND.LAM((I2-1)*NQ+N).EQ.LAM((I1-1)*NQ+N) + IF (.NOT.LTEST) GO TO 1000 +C IF WE REACH CODE BELOW,TWO SETS OF INDICES ARE IDENTICAL + IF (OKEY) WRITE(6,600) + OKEY=.FALSE. + WRITE(6,601) I1,(LAM((I1-1)*NQ+N),N=1,NQ) + WRITE(6,601) I2,(LAM((I2-1)*NQ+N),N=1,NQ) + 600 FORMAT('0 *** IVCHK. IV() INDEXING WILL NOT WORK. TERMINATING'/ + 1 ' *** IDENTICAL INDICES FOR TWO SYMMETRIES IN LAMBDA()'/ + 2 ' *** SYMMETRY/ INDICES') + 601 FORMAT(9X,I5,10I6) + 1000 CONTINUE + IF (OKEY) THEN + IF (IPRINT.GE.3) WRITE(6,*) ' IVCHK. COMPLETED SUCCESSFULLY.' + RETURN + ENDIF + STOP + END + SUBROUTINE J3J000(J2,J3,IVAL,W3J,J1MIN) + IMPLICIT DOUBLE PRECISION (A-H,J-M,O-Z) + DIMENSION W3J(1) +C + A(J1)=SQRT((J1*J1-DJ23S)*(J23P1S-J1*J1)) +C + DATA ZERO/0.0D0/,ONE/1.0D0/,TWO/2.0D0/,HALF/0.5D0/,ONPO/1.1D0/, + $ MZERO/1.0D-34/,TENTH/0.1D0/ +C +C THIS SUBROUTINE CALCULATES A SEQUENCE OF 3-J SYMBOLS FOR FIXED J2, +C J3, M2=M3=0 FOR J1MIN.LE.J1.LE.J1MAX USING THE RECURSIVE METHOD OF +C K. SCHULTEN AND R. G. GORDON, J. MATH. PHYS., VOL. 10, P. 1971, +C (1975). PROGRAMMED BY D. E. FITZ, 9/16/79. +C +C NOT TESTED FOR HALF-INTEGER QUANTUM NUMBERS. +C + JJ2P1=J2*(J2+ONE) + JJ3P1=J3*(J3+ONE) + DJ23S=(J2-J3)**2 + J23P1S=(J2+J3+ONE)**2 + J1MIN=ABS(J2-J3) + J1MAX=J2+J3 + SGNV=J2-J3 + SGN=ONE + IF(SGNV.LT.ZERO) SGN=-ONE + ISGN=INT(SGNV+SGN*TENTH) + SGN=ONE + IF(MOD(ISGN,2).NE.0) SGN=-ONE + IVAL=INT(J1MAX-J1MIN+TENTH)/2+1 +C +C RIGHT RECURSION. +C + 20 NMID=IVAL/2+1 + W3J(1)=HALF + IF(IVAL.EQ.1) GO TO 40 + J1=J1MIN + DO 21 IM2=2,NMID + J1=J1+TWO + 21 W3J(IM2)=-A(J1-ONE)*W3J(IM2-1)/A(J1) + IF(IVAL.EQ.2) GO TO 40 + SCALE=W3J(NMID) +C +C LEFT RECURSION. +C + 30 W3J(IVAL)=HALF + J1=J1MAX + IEND=IVAL-NMID + DO 32 IM2=1,IEND + W3J(IVAL-IM2)=-A(J1)*W3J(IVAL-IM2+1)/A(J1-ONE) + 32 J1=J1-TWO +C +C MATCH LEFT AND RIGHT RECURSIVE RESULTS BY SCALING. +C + 31 SCALE=SCALE/W3J(NMID) + DO 33 IM2=NMID,IVAL + 33 W3J(IM2)=SCALE*W3J(IM2) +C +C NORMALIZE RESULTS AND SET PHASE. +C + 40 SUM=ZERO + DO 41 IM2=1,IVAL + J1=J1MIN+TWO*DBLE(IM2-1) + 41 SUM=SUM+(TWO*J1+ONE)*W3J(IM2)**2 + RNORM=ONE/SQRT(SUM) + IF((SGN*W3J(IVAL)).LT.ZERO) RNORM=-RNORM + DO 42 IM2=1,IVAL + 42 W3J(IM2)=W3J(IM2)*RNORM + RETURN + END + SUBROUTINE J6J(J2,J3,L1,L2,L3,IVAL,J1MIN,D6J) + IMPLICIT DOUBLE PRECISION (A-H,J-Z) + DIMENSION D6J(2) + DATA ZERO/0.D0/,TENTH/0.1D0/,HALF/0.5D0/,ONE/1.D0/,TWO/2.D0/, + $ CONST/1.0D-12/ + E(J1S)=SQRT((J1S-MJ23S)*(J23P1S-J1S)*(J1S-ML23S)*(L23P1S-J1S)) + F(J1,JJP1)=(TWO*J1+ONE)*(JJP1*(FACT-JJP1-TWO*LLP1)+FACT2) +C +C THIS ROUTINE CALCULATES THE 6-J COEFFICIENTS FOR ALL PERMISSIBLE +C VALUES OF J1 FOR FIXED VALUES OF J2, J3, L1, L2, AND L3 USING THE +C RECURSIVE ALGORITHM OF K. SCHULTEN AND R. G. GORDON, J. MATH. PHYS. +C VOL. 16, P. 1961, (1975). +C PROGRAMMED BY D. E. FITZ, 10/22/79 +C MODIFIED BY S. GREEN 20 AUG 93 TO TEST DIMENSION ON D6J +C + MXDIM=IVAL + JJP2=J2*(J2+ONE) + JJP3=J3*(J3+ONE) + LLP1=L1*(L1+ONE) + LLP2=L2*(L2+ONE) + LLP3=L3*(L3+ONE) + MJ23S=(J2-J3)**2 + ML23S=(L2-L3)**2 + J23P1S=(J2+J3+ONE)**2 + L23P1S=(L2+L3+ONE)**2 + FACT2=(LLP2-LLP3)*(JJP2-JJP3) + FACT=JJP2+JJP3+LLP2+LLP3 + J1MIN=MAX(ABS(J2-J3),ABS(L2-L3)) + J1MAX=MIN(J2+J3,L2+L3) + IVAL=INT(J1MAX-J1MIN+ONE+TENTH) + IF (IVAL.GT.MXDIM) THEN + WRITE(6,*) 'J6J: ARRAY D6J TOO SMALL. NEEDS ',IVAL,' BUT ONLY ', + 1 MXDIM,' SUPPLIED' + STOP + ENDIF +C +C TEST FOR OTHER TRIANGULAR INEQUALITES. +C + IL1=INT(TWO*L1+TENTH) + IL2=INT(TWO*L2+TENTH) + IL3=INT(TWO*L3+TENTH) + IJ2=INT(TWO*J2+TENTH) + IJ3=INT(TWO*J3+TENTH) + IF((IJ2.LE.IL1+IL3.AND.IJ2.GE.IABS(IL1-IL3)).AND. + $ (IJ3.LE.IL1+IL2.AND.IJ3.GE.IABS(IL1-IL2))) GO TO 11 + DO 12 I=1,IVAL + 12 D6J(I)=ZERO + RETURN +C + 11 INMID=(IVAL+3)/2 + SGNV=J2+J3+L2+L3 + SGN=ONE + ISIGN=INT(SGNV+TENTH) + IF(MOD(ISIGN,2).NE.0) SGN=-ONE + D6J(1)=HALF +C +C UPWARD RECURSION. +C + IF(IVAL.EQ.1) GO TO 40 + JJP1=J1MIN*(J1MIN+ONE) + F1=F(J1MIN,JJP1) + J1=J1MIN+ONE + J1S=J1*J1 + E2=E(J1S) + IF(J1MIN.LT.TENTH) GO TO 15 + D6J(2)=-F1*D6J(1)/(E2*J1MIN) + GO TO 16 + 15 D6J(2)=-HALF*(LLP2+JJP2-LLP1)*D6J(1)/SQRT(JJP2*LLP2) + 16 SCALE=D6J(2) + IF(IVAL.EQ.2) GO TO 40 + DO 21 IJ2=3,INMID + JJP1=J1*(J1+ONE) + F1=F(J1,JJP1) + J1=J1+ONE + E1=E2 + J1S=J1*J1 + E2=E(J1S) + 21 D6J(IJ2)=-(F1*D6J(IJ2-1)+J1*E1*D6J(IJ2-2))/(E2*(J1-ONE)) + SCALE=D6J(INMID) + IEXC=5 + IF(ABS(SCALE).GT.CONST) GO TO 18 + INMID=INMID-1 + SCALE=D6J(INMID) + IEXC=3 + GO TO 30 + 18 IF(IVAL.EQ.3) GO TO 40 +C +C DOWNWARD RECURSION. +C + 30 D6J(IVAL)=HALF + J1=J1MAX + J1S=J1*J1 + JJP1=J1*(J1+ONE) + F1=F(J1,JJP1) + E1=E(J1S) + D6J(IVAL-1)=-F1*D6J(IVAL)/(E1*(J1+ONE)) + IEND=IVAL-INMID + IF(IVAL.LE.IEXC) GO TO 31 + DO 32 IJ2=2,IEND + J1=J1-ONE + E2=E1 + J1S=J1*J1 + JJP1=J1*(J1+ONE) + E1=E(J1S) + F1=F(J1,JJP1) + 32 D6J(IVAL-IJ2)=-(J1*E2*D6J(IVAL-IJ2+2)+F1*D6J(IVAL-IJ2+1))/ + $ (E1*(J1+ONE)) +C +C MATCH UPWARD AND DOWNWARD RECURSIVE RESULTS BY SCALING. +C + 31 SCALE=SCALE/D6J(INMID) + DO 33 IJ2=INMID,IVAL + 33 D6J(IJ2)=SCALE*D6J(IJ2) +C +C NORMALIZE RESULTS AND SET PHASE. +C + 40 SUM=ZERO + DO 41 IJ2=1,IVAL + J1=J1MIN+DBLE(IJ2-1) + 41 SUM=SUM+(TWO*J1+ONE)*D6J(IJ2)**2 + RNORM=ONE/SQRT(SUM*(TWO*L1+ONE)) + IF((SGN*D6J(IVAL)).LT.ZERO) RNORM=-RNORM + DO 42 IJ2=1,IVAL + 42 D6J(IJ2)=D6J(IJ2)*RNORM + RETURN + END + SUBROUTINE J6TO4(NLEV,JLEV,ATAU,JLNW,NAVAIL,ELEVNW,JLEVNW) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION JLEV(1),ATAU(1),JLNW(NAVAIL),ELEVNW(MXEL),JLEVNW(MXJL) + +C CMBASE FOR VERSION 14 (AUG 94) + DIMENSION BE(2),ALPHAE(2),DE(2) + EQUIVALENCE (BE(1),AAE(1)), (ALPHAE(1),BBE(1)), (DE(1),CCE(1)) + COMMON /CMBASE/ AAE(2),BBE(2),CCE(2),ROTI(6),ELEVEL(1000),EMAX, + 1 WT(2),SPNUC,NLEVEL,JLEVEL(4000),JMIN,JMAX,JSTEP,ISYM(10), + 2 J2MIN,J2MAX,J2STEP,ISYM2(10),JHALF,IDENT,MXJL,MXEL +C +C WE MUST BE ABLE TO GET J2 FROM J2MIN,J2MAX,J2STEP +C AND CALCULATE LINEAR ROTOR ENERGY FROM BE(2) + WRITE(6,641) J2MIN,J2MAX,J2STEP + 641 FORMAT(/' *** J6TO4. COMBINING ASYMMETRIC ROTOR AND LINEAR ROTOR' + 1 /' LINEAR ROTOR LEVELS FROM J2MIN =',I3, + 2 ', J2MAX =',I3,', J2STEP =',I2) + J2MIN=MAX0(J2MIN,0) + J2MAX=MAX0(J2MAX,J2MIN) + J2STEP=MAX0(J2STEP,1) + IF (BE(2).LE.0.D0) THEN + IF (J2MAX.EQ.0) THEN +C SET ARBITRARY BE(2) SINCE ENERGY WILL ALWAYS BE ZERO + BE(2)=1.D0 + ELSE + WRITE(6,*) ' *** SET4/J6TO4. CANNOT OBTAIN LINEAR ROTOR', + 1 ' ENERGY FROM BE(2)' + STOP + ENDIF + ENDIF + WRITE(6,644) BE(2) + 644 FORMAT(/' LINEAR ROTOR ENERGY LEVELS COMPUTED FROM B(E) =',F12.6) + IF (ALPHAE(2).NE.0.D0) WRITE(6,645) ALPHAE(2) + 645 FORMAT(27X,'CORRECTED FOR ALPHA(E) = ',F12.8) + IF (DE(2).NE.0.D0) WRITE(6,646) DE(2) + 646 FORMAT(27X,'CORRECTED FOR D(E) = ',F12.8) + IF (EMAX.GT.0.D0) WRITE(6,648) EMAX + 648 FORMAT(/' ENERGY CAP ON BASIS FUNCTIONS IS EMAX =',F14.4) +C +C NLNW COUNTS NEW 'NLEVEL'; INEW COUNTS NEW 'NLEV' + MINA=9999999 + MAXA=0 + INEW=0 + NLNW=0 + ITOP=0 + NKVAL=0 + MXNEW=NAVAIL/8 +C LOOP OVER ITYPE=6 FORMAT IN JLEV(NLEV,6) + JMIN=9999999 + JMAX=0 + DO 1000 IOLD=1,NLEV + J1=JLEV(IOLD) + ITAU=JLEV(NLEV+IOLD) + IPAR=JLEV(2*NLEV+IOLD) + ISTA=JLEV(3*NLEV+IOLD) + NK=JLEV(4*NLEV+IOLD) + MINA=MIN(MINA,ISTA+1) + MAXA=MAX(MAXA,ISTA+NK) + NKVAL=NKVAL+NK + INDX=JLEV(5*NLEV+IOLD) + IF (INDX.NE.IOLD) WRITE(6,690) INDX,IOLD + 690 FORMAT(' *** J6TO4. PROBABLY ERROR. INDX.NE.I',2I6) +C EXPAND ON J2 + DO 2000 J2=J2MIN,J2MAX,J2STEP + FJ=DBLE(J2) + FJ=FJ*(FJ+1.D0) + E2=(BE(2)-ALPHAE(2)*0.5D0)*FJ - DE(2)*FJ*FJ + EN=ELEVEL(INDX) + E2 + IF (EMAX.GT.0.D0 .AND. EN.GT.EMAX) GO TO 2000 + NLNW=NLNW+1 + IF (NLNW.GT.MXEL) THEN + WRITE(6,*) ' *** J6TO4. NUMBER LEVELS EXCEEDS MXEL',MXEL + STOP + ENDIF + ELEVNW(NLNW)=EN + JLEVNW(3*NLNW-2)=J1 + JLEVNW(3*NLNW-1)=ITAU + JLEVNW(3*NLNW)=J2 + IF (JLEVEL(2*INDX-1).NE.J1 .OR. JLEVEL(2*INDX).NE.ITAU) THEN + WRITE(6,*) ' *** J6TO4. INCOMPATIBLE JLEVEL(), JLEV() FOR' + WRITE(6,*) ' LEVEL',INDX + ENDIF +C EXPAND J1+J2 TO J12; NEED TO SET JMIN,JMAX TO MIN/MAX OF J12 +C FOR USE IN PICKING ORBITAL MOMENTA FOR A GIVEN JTOT + DO 3000 J12=ABS(J1-J2),J1+J2 + INEW=INEW+1 + IF (INEW.GT.MXNEW) THEN + WRITE(6,*) ' *** J6TO4. SCRATCH SPACE EXCEEDED FOR BASIS NO.' + 1 ,INEW + STOP + ENDIF + JLNW(ITOP+1)=J12 + JLNW(ITOP+2)=J2 + JLNW(ITOP+3)=J1 + JLNW(ITOP+4)=ITAU + JLNW(ITOP+5)=IPAR + JLNW(ITOP+6)=ISTA + JLNW(ITOP+7)=NK + JLNW(ITOP+8)=NLNW + JMIN=MIN(JMIN,J12) + JMAX=MAX(JMAX,J12) + 3000 ITOP=ITOP+8 + 2000 CONTINUE + 1000 CONTINUE +C +C COPY JLEVNW,ELEVNW BACK TO JLEVEL,ELEVEL + DO 4000 I=1,NLNW + ELEVEL(I)=ELEVNW(I) + JLEVEL(3*I-2)=JLEVNW(3*I-2) + JLEVEL(3*I-1)=JLEVNW(3*I-1) + 4000 JLEVEL(3*I)=JLEVNW(3*I) +C SHIFT ATAU UP TO REFLECT START AT 6*NLEV+1 TO 8*INEW+1 + IF (NKVAL.NE.MAXA-MINA+1) + 1 WRITE(6,*) ' POSSIBLE ERROR. MINA,MAXA,NKVAL',MINA,MAXA,NKVAL + MOVE=8*INEW-6*NLEV + DO 4500 I=1,NKVAL + 4500 ATAU(8*INEW+NKVAL+1-I)=ATAU(6*NLEV+NKVAL+1-I) +C SHIFT ISTA (JLNW(6,I)) TO REFLECT MOVED ATAU + IX=6 + DO 4600 I=1,INEW + JLNW(IX)=JLNW(IX)+MOVE + 4600 IX=IX+8 +C RESET NLEV; COPY JLNW TO JLEV, CORRECTING ORDER + NLEV=INEW + ITOP=0 + DO 5000 I=1,NLEV + IX=I + DO 5100 II=1,8 + ITOP=ITOP+1 + JLEV(IX)=JLNW(ITOP) + 5100 IX=IX+NLEV + 5000 CONTINUE + RETURN + END + SUBROUTINE J9J(J1,J2,J4,J5,J6,J7,J8,J9,IVAL,J3MIN,D9J) + IMPLICIT DOUBLE PRECISION (A-H,J-Z) + DIMENSION D9J(1),D6J3(200),D6J5(200),D6J7(200) + DATA MXDIM6/200/ + DATA ZERO/0.D0/,TENTH/0.1D0/,HALF/0.5D0/,ONE/1.D0/,TWO/2.D0/ +C +C THIS ROUTINE CALCULATES THE 9-J SYMBOLS BY SUMMATION OVER 6-J +C SYMBOLS WHICH IN TURN ARE CALCULATED BY THE RECURSIVE METHOD +C OF SCHULTEN AND GORDON. +C PROGRAMMED BY D. E. FITZ, 22 OCT 79. +C +C MODIFIED BY M. L. DUBERNET, 15 SEP 93 AND J. M. HUTSON, 3 OCT 93 +C TO ALLOW HALF-INTEGER ANGULAR MOMENTA +C MODIFIED BY J. M. HUTSON, 3 OCT 93 TO CHECK D9J DIMENSION +C + MXDIM9=IVAL + J3MIN=MAX(ABS(J1-J2),ABS(J6-J9)) + J3MAX=MIN(J1+J2,J6+J9) + IJ3N=INT(TWO*J3MIN+TENTH) + IJ3X=INT(TWO*J3MAX+TENTH) + IVAL=1+(IJ3X-IJ3N)/2 + IF(IVAL.GT.MXDIM9) THEN + WRITE(6,*) 'J9J: ARRAY D9J TOO SMALL. NEEDS ',IVAL,' BUT ONLY ', + 1 MXDIM9,' SUPPLIED' + STOP + ENDIF +C +C TEST FOR TRIANGULAR INEQUALITIES. +C + D9J(1)=ZERO + IF (IVAL.LE.0) RETURN + IJ1=INT(TWO*J1+TENTH) + IJ2=INT(TWO*J2+TENTH) + IJ4=INT(TWO*J4+TENTH) + IJ5=INT(TWO*J5+TENTH) + IJ6=INT(TWO*J6+TENTH) + IJ7=INT(TWO*J7+TENTH) + IJ8=INT(TWO*J8+TENTH) + IJ9=INT(TWO*J9+TENTH) + DO 15 IJL=1,IVAL + 15 D9J(IJL)=ZERO + IF((IJ4-IABS(IJ7-IJ1))*(IJ7+IJ1-IJ4).LT.0) RETURN + IF((IJ5-IABS(IJ8-IJ2))*(IJ8+IJ2-IJ5).LT.0) RETURN + IF((IJ5-IABS(IJ6-IJ4))*(IJ6+IJ4-IJ5).LT.0) RETURN + IF((IJ8-IABS(IJ9-IJ7))*(IJ9+IJ7-IJ8).LT.0) RETURN +C + IVAL7=MXDIM6 + CALL J6J(J1,J9,J7,J8,J4,IVAL7,JMIN7,D6J7) +C + IVAL5=MXDIM6 + CALL J6J(J6,J2,J5,J8,J4,IVAL5,JMIN5,D6J5) +C + JMIN=MAX(JMIN5,JMIN7) + JMAX=MIN(J1+J9,J2+J6,J4+J8) + IEND=INT(JMAX-JMIN+TENTH+ONE) + I5=INT(JMIN-JMIN5+TENTH) + I7=INT(JMIN-JMIN7+TENTH) +C +C LOOP RUNS OVER TWICE J3 TO ALLOW HALF-INTEGER VALUES +C + ITAB=0 + DO 20 IJ3=IJ3N,IJ3X,2 + ITAB=ITAB+1 + J3=HALF*DBLE(IJ3) +C + IVAL3=MXDIM6 + CALL J6J(J1,J9,J3,J6,J2,IVAL3,JMIN3,D6J3) + I3=INT(JMIN-JMIN3+TENTH) + SUM=ZERO +C + DO 10 I=1,IEND + J=DBLE(I-1)+JMIN + SGN=ONE + ISIGN=INT(TWO*J+TENTH) + IF(MOD(ISIGN,2).NE.0) SGN=-ONE + SUM=SUM+(TWO*J+ONE)*SGN*D6J3(I+I3)*D6J5(I+I5)*D6J7(I+I7) + 10 CONTINUE + D9J(ITAB)=SUM + 20 CONTINUE + RETURN + END + SUBROUTINE KSYM(AK,N) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION AK(N,N) + DO 10 I=1,N + DO 10 J=1,I + TMP=0.5D0*(AK(I,J)+AK(J,I)) + AK(I,J)=TMP + AK(J,I)=TMP + 10 CONTINUE + RETURN + END + SUBROUTINE KTOS(R,SR,SI,NOP) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION R(1),SR(1),SI(1) +C +C ROUTINE TO OBTAIN THE S MATRIX FROM THE REACTANCE (K) MATRIX +C ALTHOUGH THIS ROUTINE USES SYMMETRIC MATRIX MULTIPLICATION, +C THE WHOLE OF R MUST BE SUPPLIED AND THE WHOLE OF SR AND +C SI ARE RETURNED. +C +C I + R*R IS POSITIVE DEFINITE, SO SYMINV CANNOT FAIL +C + NOPP1=NOP+1 + NOPSQ=NOP*NOP + CALL DSYMM('L','L',NOP,NOP,0.5D0,R,NOP,R,NOP,0.D0,SR,NOP) + DO 10 II=1,NOPSQ,NOPP1 + 10 SR(II)=SR(II)+0.5D0 + CALL SYMINV(SR,NOP,NOP,IFAIL) + CALL DSYFIL('U',NOP,SR,NOP) + CALL DSYMM('L','L',NOP,NOP,1.D0,SR,NOP,R,NOP,0.D0,SI,NOP) + DO 30 II=1,NOPSQ,NOPP1 + 30 SR(II)=SR(II)-1.D0 + RETURN + END + SUBROUTINE LDPROP(U,Z,N,RBEGIN,REND,NSTEP, + X ESHIFT,IREAD,IWRITE,ISCRU, + X P,VL,IV,ERED,EINT,CENT,RMLMDA,DG,MXLAM,NPOTL,ISTART,NODES) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + LOGICAL IREAD,IWRITE + DIMENSION U(N,N),Z(N,N),P(MXLAM),VL(2),IV(2),EINT(N),CENT(N),DG(N) +C + H = (REND-RBEGIN)/DBLE(2*NSTEP) + D1 = H*H/3.D0 + D2 = 2.D0*D1 + D4 = -D1/16.D0 + R = RBEGIN + NODES=0 + IF( .NOT. IREAD) GO TO 100 + READ(ISCRU) U + DO 90 I = 1,N + 90 U(I,I)=U(I,I)-ESHIFT + GO TO 110 + 100 CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DG,MXLAM,NPOTL) + IF(IWRITE) WRITE(ISCRU) U +C + 110 IF(ISTART.EQ.1) GO TO 135 + SGN=1.D0 + IF(REND.LT.RBEGIN) SGN=-1.D0 + DO 130 J = 1,N + DO 120 I = J,N + 120 Z(I,J) = 0.D0 + Z(J,J) = SGN*1.D30 + 130 IF(U(J,J).GT.0.D0) Z(J,J) = SGN*SQRT(U(J,J)) + 135 CONTINUE +C + DO 150 J = 1,N + DO 140 I = J,N + 140 Z(I,J) = H*Z(I,J)+D1*U(I,J) + 150 Z(J,J) = 1.D0+Z(J,J) +C + DO 260 ISTEP = 1,NSTEP + R = R+H + IF( .NOT. IREAD) GO TO 160 + READ(ISCRU) U + ESH=-D4*ESHIFT + DO 155 I=1,N + 155 U(I,I)=U(I,I)+ESH + GO TO 190 + 160 CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DG,MXLAM,NPOTL) + DO 180 J = 1,N + DO 170 I = J,N + 170 U(I,J) = D4*U(I,J) + 180 U(J,J) = 0.125D0+U(J,J) + IF(IWRITE) WRITE(ISCRU) U + 190 CALL SYMINV(U,N,N,NCU) + IF(NCU.GT.N) GO TO 900 + CALL SYMINV(Z,N,N,NCZ) + IF(NCZ.GT.N) GO TO 900 + NODES=NODES+NCZ + DO 210 J = 1,N + DO 200 I = J,N + 200 Z(I,J) = U(I,J)-Z(I,J) + 210 Z(J,J) = Z(J,J)-6.D0 + CALL SYMINV(Z,N,N,NCZ) + IF(NCZ.GT.N) GO TO 900 + NODES=NODES+NCZ-NCU + R = R+H + IF(ISTEP.EQ.NSTEP) D2=D1 + IF( .NOT. IREAD) GO TO 220 + READ(ISCRU) U + ESH=-D2*ESHIFT + DO 215 I=1,N + 215 U(I,I)=U(I,I)+ESH + GO TO 245 + 220 CALL WAVMAT(U,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DG,MXLAM,NPOTL) + DO 240 I=1,N + DO 230 J=1,I + 230 U(I,J)=D2*U(I,J) + 240 U(I,I)=U(I,I)+2.D0 + IF(IWRITE) WRITE(ISCRU) U + 245 DO 250 J = 1,N + DO 250 I = J,N + 250 Z(I,J) = U(I,J)-Z(I,J) + 260 CONTINUE +C + HI = 1.D0/H + DO 280 J = 1,N + DO 270 I = J,N + Z(I,J) = HI*Z(I,J) + 270 Z(J,I) = Z(I,J) + 280 Z(J,J) = Z(J,J)-HI + RETURN +C + 900 WRITE(6,901) + 901 FORMAT('0 *** ERROR IN SYMINV CALLED FROM LDPROP - TERMINATING') + STOP + END + SUBROUTINE LDVIVS(N,NSQ,MXLAM,NPOTL, + 1 SR,SI,W,VL,IVL,EINT,CENT,WV,L,NB, + 2 P,A1,A1P,B1,B1P, + 3 WKS,G1,G1P,G2,G2P,COSX,SINX,SINE,DIAG,XK,XSQ, + 4 TSTORE,W0,W1,W2,EYE11,EYE12,EYE22,VEC, + 5 ICODE,IPRINT) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C *** +C *** INTERFACE TO VIVAS/LDPROP +C *** ------------------------------------------------------------- +C *** ADAPTED FROM PROGRAMS OF G.A. PARKER, J.V. LILL, & J.C. LIGHT +C *** REF.: N.R.C.C. SOFTWARE CATALOG, VOL. 1, PROG. NO. KQ04, 1980. +C *** ------------------------------------------------------------- +C *** ICODE.EQ.2 FOR SUBSEQUENT ENERGY. +C *** + DIMENSION SR(NSQ),SI(NSQ),W(NSQ),VL(2),IVL(2), + 1 EINT(N),CENT(N),WV(N),L(N),NB(N), + 2 P(MXLAM),A1(N),A1P(N),B1(N),B1P(N), + 3 WKS(N),G1(N),G1P(N),G2(N),G2P(N), + 4 COSX(N),SINX(N),SINE(N),DIAG(N),XK(N),XSQ(N), + 5 TSTORE(NSQ),W0(NSQ),W1(NSQ),W2(NSQ), + 6 EYE11(NSQ),EYE12(NSQ),EYE22(NSQ),VEC(NSQ) +C + COMMON/DRIVE/STEST,STEPS,STABIL,CONV,RMIN,RMAX,XEPS,DR, + 1 DRMAX,RVIVAS,TOLHI,RTURN,VTOL,ESHIFT,ERED,RMLMDA, + 2 NOPEN,JKEEP,ISCRU,MAXSTP +C + LOGICAL IALFP,IV,IVP,IVPP,ISHIFT,IDIAG,IPERT,ISYM,IREAD,IWRITE + COMMON /LDVVCM/ XSQMAX,ALPHA1,ALPHA2,IALPHA,IALFP,IV,IVP, + 1 NUMDER,IVPP,ISHIFT,IDIAG,IPERT,ISYM,IREAD,IWRITE +C +C LOGICAL VARIABLES + LOGICAL LLD,LVIVS +C +C----------------------------------------------------------------- +C SET UP TO USE UNIT (ISCRU) + IREAD = ICODE.EQ.2 .AND. ISCRU.GT.0 + IWRITE = ICODE.EQ.1 .AND. ISCRU.GT.0 +C------------------------------------------------------------------- + IF(IWRITE) WRITE(ISCRU) RMIN,RVIVAS,RMAX + IF(IREAD) READ (ISCRU) RMIN,RVIVAS,RMAX +C +C DECIDE WHICH CALCULATIONS (LDPROP/VIVAS) ARE DESIRED +C + LLD= RMIN.LT.RVIVAS + LVIVS= RMAX.GT.RVIVAS + IF (LLD.OR.LVIVS) GO TO 130 + WRITE(6,699) RMIN,RVIVAS,RMAX + 699 FORMAT('0 * * * ERROR. NULL CALCULATION REQUESTED.'/ + & ' RMIN, RVIVAS, RMAX =',3E14.4) + STOP +C + 130 RMID=MIN(RMAX,RVIVAS) + RMID=MAX(RMIN,RMID) +C +C CALCULATE WAVEVECTORS, AND STEP SIZE FOR LDPROP +C + BIG=0.D0 + NOPEN=0 + DO 190 I=1,N + DIF=ERED-EINT(I) + WV(I)=SIGN(SQRT(ABS(DIF)),DIF) + BIG=MAX(BIG,WV(I)) + NB(I)=I + 190 IF(DIF.GT.0.D0) NOPEN=NOPEN+1 + IF(NOPEN.LE.0) RETURN + IF(IREAD) THEN + READ(ISCRU) NSTEP + ELSE + NSTEP=BIG*STEPS*(RMID-RMIN)/ACOS(-1.D0) + IF(IWRITE) WRITE(ISCRU) NSTEP + ENDIF + LLD = LLD .AND. NSTEP.GT.0 +C------------------------------------------------------------------- +C PROPAGATE THE LOG-DERIVATIVE MATRIX THROUGH THE SCATTERING REGION + IF (.NOT.LLD) GO TO 200 + CALL LDPROP(W,SR,N,RMIN,RMID,NSTEP, + & ESHIFT,IREAD,IWRITE,ISCRU, + & P,VL,IVL,ERED,EINT,CENT,RMLMDA,A1,MXLAM,NPOTL,0,NODES) + IF(IPRINT.GE.3) WRITE(6,195) RMIN,RMID,NSTEP + 195 FORMAT('0 LDPROP. LOG DERIVATIVE MATRIX INTEGRATED FROM ', + & F12.4,' TO ',F12.4,' IN ',I6,' STEPS.') + 200 IF (.NOT.LVIVS) GO TO 210 +C GET R-MATRIX BY INVERTING LOGD OR BY DIRECT INITIALIZATION + IF (LLD) THEN + CALL SYMINV(SR,N,N,IFAIL) + CALL DSYFIL('U',N,SR,N) + ELSE + N1=N+1 + DO 170 I=1,NSQ + 170 SR(I)=0.D0 + DO 180 I=1,NSQ,N1 + 180 SR(I)=1.D30 + ENDIF + DRNOW=DR +C SET TLDIAG/TOFF FROM TOLHI. C.F. NRCC DEFAULTS OF .064 + TLDIAG=.064D0*SQRT(TOLHI/.001D0) + TOFF=TLDIAG + CALL VIVAS(N,NSQ,DRNOW,RMID,RMAX,DRMAX,TLDIAG,TOFF,ESHIFT, + & SR,EYE11,EYE12,EYE22,W,W0,W1,W2,TSTORE,VEC,SI, + & G1,G1P,G2,G2P,A1,A1P,B1,B1P,XSQ,XK,COSX, + & SINX,SINE,DIAG,NOPEN,IPRINT,ISCRU, + & P,VL,IVL,ERED,EINT,CENT,RMLMDA,MXLAM,WKS,NPOTL) +C AND CONVERT R-MATRIX BACK TO LOGD MATRIX + CALL SYMINV(SR,N,N,IFAIL) +C------------------------------------------------------------------ +C SORT CHANNELS BY ASYMPTOTIC ENERGY +C + 210 IF(N.LE.1) GOTO 230 + NM1=N-1 + DO 220 I=1,NM1 + IP1=I+1 + DO 220 J=IP1,N + IF(EINT(NB(I)).LE.EINT(NB(J))) GOTO 220 + IT=NB(I) + NB(I)=NB(J) + NB(J)=IT + 220 CONTINUE +C------------------------------------------------------------- +C CALCULATE K AND S MATRICES + 230 CALL YTOK(NB,WV,L,N,NOPEN,A1,A1P,B1,B1P,SR,SI,W,RMAX) + CALL KTOS(W,SR,SI,NOPEN) + RETURN + END + SUBROUTINE MASK + RETURN + END +* ---------------------------------------------------------------------- + SUBROUTINE MAXMGV (A, NA, C, NC, N) +* SUBROUTINE TO SCAN A VECTOR FOR ITS MAXIMUM MAGNITUDE (ABSOLUTE VAL +* ELEMENT +* CURRENT REVISION DATE: 24-SEPT-87 +* ------------------------------------------------------------------- +* VARIABLES IN CALL LIST: +* A: FLOATING POINT INPUT VECTOR +* NA: INTEGER ELEMENT STEP FOR A +* C: FLOATING POINT OUTPUT SCALAR: ON RETURN CONTAINS VALUE OF +* MAXIMUM MAGNITUDE (ABSOLUTE VALUE) ELEMENT +* NC: INTEGER INDEX OF MAXIMUM MAGNITUDE ELEMENT +* N: INTEGER ELEMENT COUNT +* SUBROUTINES CALLED: +* IDAMAX: BLAS ROUTINE TO FIND INDEX OF MAXIMUM MAGNITUDE (ABSOLUTE V +* ELEMENT +* ------------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + INTEGER IDAMAX, N, NA, NC + DIMENSION A(1) + NC = ( IDAMAX (N, A, NA) - 1) * NA + 1 + C = ABS( A(NC) ) + RETURN + END + SUBROUTINE MCGCPL(N,MXLAM,NPOTL,LAM,NLEV,JLEV,J,L,MVALUE,ITYPE, + 1 IEX,VL,IV,PRINT) +C MODIFIED FOR ITYPE=4 BY SG 29 JUN 94 + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE LFIRST + INTEGER PRINT + INTEGER LAM(2),JLEV(NLEV,3),J(2),L(2),IV(1) + DIMENSION VL(2) + LOGICAL LFIRST +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C + DATA SQRTHF/.70710678118654753D0/, Z0/0.D0/ +C STATEMENT FUNCTION DEFINITION . . . + Z(I)=DBLE(I+I+1) +C + IF (ITYPE.EQ.21) GO TO 1000 + IF (ITYPE.EQ.22) GO TO 2000 + IF (ITYPE.EQ.23) GO TO 3000 + IF (ITYPE.EQ.24) GO TO 4000 + IF (ITYPE.EQ.25) GO TO 5000 + IF (ITYPE.EQ.26) GO TO 6000 + IF (ITYPE.EQ.27) GO TO 7000 + STOP +C + 1000 IF (IVLFL.NE.0) GO TO 9999 + CALL CPL21(N,MXLAM,LAM,NLEV,JLEV,J,MVALUE,VL,PRINT,LFIRST) + RETURN +C + 2000 IF (IVLFL.LE.0) GO TO 9999 + CALL CPL22(N,MXLAM,NPOTL,LAM,NLEV,JLEV,J,MVALUE, + 1 IV,VL,PRINT,LFIRST) + RETURN +C + 3000 IF (IVLFL.NE.0) GO TO 9999 + CALL CPL23(N,MXLAM,LAM,NLEV,JLEV,J,L,MVALUE,IEX,VL,PRINT,LFIRST) + RETURN +C +CTRP>> JUN94 (SG) + 4000 CALL CPL24(N,MXLAM,LAM,NLEV,JLEV,JLEV,J,MVALUE,VL,PRINT,LFIRST) + RETURN +C< 0, THEN SUBROUTINE CALLED AT SUBSEQUENT ENERGY OF MU +* ENERGY CALCULATION, SO TRANSFORMATION MATRIX AND RELEVANT +* INFORMATION WILL BE READ +* --------------------------------------------------------------------- +C +C ----- ADAPTED TO MOLSCAT BY TRP AT NASAGISS, MAY 1991 ----- +C ----- ISCRU IS UNIT NUMBER ----- +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + INTEGER I, ITWO, NMAX + LOGICAL ISECND + DIMENSION EIGOLD(1), HP(1), TMAT(1) + ISECND = .FALSE. + IF (ITWO .GT. 0) ISECND = .TRUE. +* IF FIRST ENERGY CALCULATION, ISECND = .FALSE. +* IN WHICH CASE LOGICAL UNIT ISCRU WILL BE WRITTEN +* IF SUBSEQUENT ENERGY CALCULATION, ISECND = .TRUE. +* IN WHICH CASE LOGICAL UNIT ISCRU WILL BE WRITTEN +* READ/WRITE RNOW, DRNOW, DIAGONAL ELEMENTS OF TRANSFORMED DW/DR MATRIX +* AND DIAGONAL ELEMENTS OF TRANSFORMED W MATRIX + NSQ = NMAX * NMAX + IF (ISECND) THEN + READ (ISCRU) RNOW, DRNOW, (HP(I) , I = 1, N), + : (EIGOLD(I) , I = 1, N), (TMAT(I), I=1, NSQ) + ELSE + WRITE (ISCRU) RNOW, DRNOW, (HP(I) , I = 1, N), + : (EIGOLD(I) , I = 1, N), (TMAT(I), I=1, NSQ) + ENDIF +* NOW SHIFT ENERGIES (IF SUBSEQUENT ENERGY) + IF (ISECND) THEN + DO 30 I = 1, N + EIGOLD(I) = EIGOLD(I) + ESHIFT +30 CONTINUE + END IF + RETURN + END + SUBROUTINE OUTPUT( JTOT, NBASIS, J, L, WVEC, SREAL, SIMAG, + 1 AKMAT, CONV, NOPEN, M, MXPAR, WT, IEXCH, INRG, RM, PRNT, TTIME, + 2 ENERGY, SIG, JLEV, ISST, IECONV, MINJT, MAXJT, + 3 NLEV,NQN,OTOL,DTOL,KSAVE,ISIGU,IPARTU,ISAVEU,ISIGPR,IRSTRT,N) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE INVERR,NSTOR,ITYPE,NLEVEL,LOUT,JSTEP +C +C FOR MOLSCAT VERSION 14, JUL 1994 +C WITH RESTART (IRSTRT) CAPABILITIES +C +C ENTRY OUTPUT - PROCESSES S MATRICES TO X-SECTIONS OUTPUTS THEM. +C ENTRY OUTSIG - (10/92) SEPARATE ENTRY TO UPDATE UNIT(ISIGU) +C TO FIX BUG W/ NO BASIS FNS FOR PARITY M=MXPAR +C ENTRY OUTINT - INITIALIZATION ENTRY FROM DRIVER. +C ENTRY OUTPCH - PUNCHES FINAL CROSS SECTIONS. +C ENTRY OUTERR - SETS ERROR FLAG, CALLED ONLY FROM DVSCAT. +C +C MODIFICATIONS AUG. 74 - - - +C NLEVEL IS DIFFERENT FROM NLEV. FORMER FOR ELEVEL,JLEVEL, +C AND LATTER FOR JLEV(NLEV,NQN). +C TSIG IS NOW FIRST NLEVEL*NLEVEL=NSTOR ELEMENTS OF SIG. +C DEGENERACY IS IN 2ND NSTOR ELEMENTS OF SIG. +C MODIFIED NOV 91 - - - MULTIPLIES CROSS SECTIONS BY JSTEP +C MODIFIED JUN 92 TO GIVE UNFORMATTED ISAVEU OUTPUT W/ ONLY +C NONREDUNDANT S(I,J). OLDER (FORMATTED) CODE IS SAVED AS +C COMMENTS TO PROVIDE COMPATIBILITY W/ VERSION 10 AND EARLIER. +C N.B FORMATS 800,801,802 ALSO USED FOR IPARTU OUTPUT. +C SREAL,SIMAG ARE WRITTEN USING A SUBROUTINE SWRITE. +C 21 JAN 93 -- NEW DYNAMIC MEMORY HANDLING +C APR 94 -- MODIFED CALLING SEQUENCES, OUTPUT FORMATS +C ACCOMMODATE NEGATIVE SIG-INDEX, JLEV((NQN-1)*NLEV+I) +C AUG 95 ADDED N TO PARAMETER LIST AND WRITE(6,642) +C + DIMENSION NBASIS(1),J(1),L(1),WVEC(1),SREAL(1),SIMAG(1) + DIMENSION AKMAT(NOPEN,NOPEN) + INTEGER ISST(2),MAXJT(2),MINJT(2),IECONV(2) + INTEGER PRINT,PRNT + INTEGER NLEV,JLEV(1) + DIMENSION SIG(1),ENERGY(1) + LOGICAL OKEY,LOUT,ACCUM,OPENED,LWARN +C INTEGER CTIME(2),CDATE(4) + CHARACTER CTIME*9,CDATE*11 + CHARACTER*4 LABEL(20) + CHARACTER*1 STAR,BLANK +C + COMMON /CMBASE/ ROTI(12),ELEVEL(1004),IDUM(4031) + EQUIVALENCE (JHALF,IDUM(4028)) +C +C COMMON BLOCK TO DRIVER FOR RESONANCE SEARCHES +C + COMMON/EIGSUM/EPSM(5) +C + EQUIVALENCE (NLVL,IDUM(1)) +C + DATA STAR/'*'/, BLANK/' '/ + DATA EPS/1.D-12/ + DATA IPUNCH/7/ +C + PI=ACOS(-1.D0) + PI2=2.D0*PI +C + PRINT=PRNT +C>>SG IEXCH=1 + IRET=0 +C +C SET LOGICAL VARIABLES + OKEY=CONV.GE.0.D0 .AND. IECONV(INRG).GE.0 + ACCUM=OKEY .AND. INVERR.LE.0 .AND. ITYPE.NE.8 +C +C BOOKEEPING FOR MINJT AND MAXJT + IF (MINJT(INRG).LT.0) MINJT(INRG)=JTOT + IF (OKEY .AND. JTOT.GT.MAXJT(INRG) .AND. MAXJT(INRG).GE.0) + & MAXJT(INRG)=JTOT +C +C PRINT OUT OPEN-CHANNEL BASIS FUNCTIONS AND WAVEVECTORS IN 1/A. + IF (PRINT.GE.11) WRITE(6,601) + 601 FORMAT('0 CHANNEL NO. TARGET LEVEL ORBITAL L WVEC(1/ANG.)') +C CONVERT WVEC TO INVERSE ANGSTROMS + DO 1000 I=1,NOPEN + NB=NBASIS(I) + WVEC(NB)=WVEC(NB)/RM + IF (PRINT.GE.11) WRITE(6,602) I,J(NB),L(NB),WVEC(NB) + 602 FORMAT(3I12,E18.8) + 1000 CONTINUE +C +C +C PROCESS S-MATRIX. ACCUMULATE X-SECTIONS IN TSIG. PRINT. +C J(NBASIS(I)) IS LEVEL NUMBER OF ITH BASIS FN. IN ASYMPTOTIC AREA. +C CLEAR TSIG. + DO 1400 I=1,NSTOR + 1400 SIG(I)=0.D0 + IF (PRINT.GT.10) WRITE(6,606) + 606 FORMAT('0 ROW COL',10X,'S**2',15X,'PHASE/2PI',12X,'RE (S)',14X, + 1 'IM (S)' ) +C + IJ=0 + NTOP=(NQN-1)*NLEV +C CALCULATE GLOBAL MULTIPLICATIVE FACTOR FOR X-SECTIONS. + XJ=DBLE((2/JHALF)*JTOT+1)*PI +C>>SG CALCULATE (OR GET FROM PARM LIST) IEXCH -- FOR USE W/ISAVEU +C IF (IEXCH.NE.0) XJ=XJ*WT + IF (WT.GT.0.D0) XJ=XJ*WT + DO 2000 ICOL=1,NOPEN + LEVC=J(NBASIS(ICOL)) + LCOL=JLEV(NTOP+LEVC) + IF (LCOL.GT.0) THEN + CS1=1.D0 + ELSE + CS1=-1.D0 + LCOL=-LCOL + ENDIF + DO 2000 IROW=1,NOPEN + DD=WVEC(NBASIS(IROW)) + DD=DD*DD + LEVR=J(NBASIS(IROW)) +C IJ IS INDEX OF SREAL,SIMAG(IROW,ICOL) + IJ=IJ+1 + SMAG=( SREAL(IJ)*SREAL(IJ)+SIMAG(IJ)*SIMAG(IJ) ) + IF (PRINT.LE.10 .OR. SMAG.LE.EPS) GO TO 2300 + PHASE=ATAN2(SIMAG(IJ),SREAL(IJ)) / PI2 + IF(ITYPE.NE.8) GO TO 2100 +C SPECIAL CASE FOR SURFACE SCATTERING: WRITE OUT ONE COLUMN ONLY, +C LABELLED BY G VECTORS RATHER THAN CHANNEL NUMBERS + XJ=1.D0 + IF(JLEV(LEVC).NE.0 .OR. JLEV(NLEV+LEVC).NE.0) GOTO 2400 + WRITE(6,607) JLEV(LEVR),JLEV(NLEV+LEVR), + 1 SMAG,PHASE,SREAL(IJ),SIMAG(IJ) + GOTO 2400 +C ALL OTHER CASES + 2100 WRITE(6,607) IROW,ICOL,SMAG,PHASE,SREAL(IJ),SIMAG(IJ) + 607 FORMAT(2I5,4E20.6) + 2300 IF (IROW.NE.ICOL) GO TO 2400 +C FOR IROW = ICOL, CALCULATE T = 1 - S. + SMAG=1.D0-SREAL(IJ) + SMAG=SMAG*SMAG + SIMAG(IJ)*SIMAG(IJ) + 2400 CONTINUE +C N.B. LCOL (LROW) < 0 IMPLIES JI (JF) .GT. JZCSMX +C IF BOTH NEGATIVE, INDICATE BY NEGATIVE SIGMA + LROW=JLEV(NTOP+LEVR) + CSF=1.D0 + IF (LROW.LT.0) THEN + LROW=-LROW + IF (CS1.LT.0.D0) CSF=-1.D0 + ENDIF + IF (LROW.GT.NLEVEL .OR. LCOL.GT.NLEVEL) GO TO 2000 +C II IS INDEX OF SIG(ICOL,IROW). N.B. JLEV(LEV,NQN) HAS POINTER +C TO 'SERIAL' NUMBER OF 'LEVEL'. + II=(LROW-1)*NLEVEL+LCOL +C ACCOUNT FOR K(J,J), DEGEN. LATTER IN SIG(NSTOR+II). + SIG(II) = SIG(II) + CSF * SMAG*XJ/(SIG(NSTOR+II)*DD) + 2000 CONTINUE +C +C ACCUMULATE X-SECTIONS. SET IJ TO START OF INRG-TH ENERGY IN SIG + 4100 IJ=(INRG+1)*NSTOR + II=0 + XII=0.D0 + XIJ=0.D0 + DO 3000 JI=1,NLEVEL + DO 3000 I=1,NLEVEL + II=II+1 + IJ=IJ+1 + IF ( ACCUM ) SIG(IJ)=SIG(IJ)+SIG(II) + IF (JI.EQ.I) GO TO 3100 + XIJ=MAX(XIJ,ABS( SIG(II))) + GO TO 3000 + 3100 XII=MAX(XII,ABS( SIG(II))) + 3000 CONTINUE +C + IF (ACCUM) GO TO 5101 +C CODE BELOW IS REACHED IF SIGMA NOT ACCUMULATED. . . + IF (ITYPE.EQ.8) GO TO 6500 + IF (OKEY) GO TO 9100 + WRITE(6,9600) + 9600 FORMAT(' ****** SIGMA NOT ACCUMULATED DUE TO LACK OF CONVERGENCE', + 1 ' IN THIS OR PREVIOUS CALCULATION.') + IF(ISAVEU.GT.0) WRITE(6,9632) + 9632 FORMAT(' ****** SCATTERING MATRIX NOT SAVED') + MAXJT(INRG)=-IABS(MAXJT(INRG)) + IECONV(INRG)=MIN0(IECONV(INRG)-1,-1) + GO TO 6500 +C + 9100 WRITE(6,9611) INVERR + 9611 FORMAT(' ****** SIGMA NOT ACCUMULATED BECAUSE OF MATRIX ', + 1 'INVERSION ERROR',I4) + IF(ISAVEU.GT.0) WRITE(6,9632) + GO TO 6500 +C +C BELOW REACHED IF SIGMA ACCUMULATED. OUTPUT, SAVE ON TAPE, DISK. +C + 5101 IF(PRINT.EQ.1) THEN + WRITE(6,642) JTOT,M,INRG,ENERGY(INRG),XII,XIJ,N,NOPEN + ELSEIF(PRINT.GT.1) THEN + WRITE(6,642) JTOT,M,INRG,ENERGY(INRG),XII,XIJ,N,NOPEN,TTIME + 642 FORMAT(' JTOT=',I4,'.',I2,' E(',I3, + 1 ')=',F10.3,', MAX D/O-D=',1P,2D9.1,' N/NOP=',2I5, + 2 2X,'TIME=',0P,F8.2) + ENDIF +C + IF(ISIGPR.LE.0) GO TO 5100 + IF (PRINT.LE.4) GO TO 5100 + WRITE(6,9601) + 9601 FORMAT('0',8(' * '),'PARTIAL CROSS SECTIONS',8(' * ')) + DO 5200 I=1,NLEVEL +C5200 WRITE(6,631) (ABS(SIG((II-1)*NLEVEL+I)),I,II, II=1,NLEVEL) +C BELOW INCORPORATES JMH V12 UPDATE AND SG V13X UPDATE + IF (ENERGY(INRG).GT.ELEVEL(I)) + 1WRITE(6,631) (ABS(SIG((II-1)*NLEVEL+I)),I,II, II=1,NLEVEL) + 5200 CONTINUE + 631 FORMAT('0',4(1P,D10.2,' FOR SIG(',2I3,')' )/ + 1 ( ' ',4(1P,D10.2,' FOR SIG(',2I3,')' ))) + IF (PRINT.LE.10) GO TO 5100 + WRITE(6,9602) MINJT(INRG),JTOT + 9602 FORMAT('0',6(' * '),'CROSS SECTIONS ACCUMULATED FROM JTOT=', + 1 I4,' TO',I4,6(' * ')) + ISTART=(INRG+1)*NSTOR + XJS=DBLE(JSTEP)/DBLE(JHALF) + IF (JSTEP.NE.1) WRITE(6,9630) XJS + 9630 FORMAT(31X,'MULTIPLIED BY',F5.1,' TO ACCOUNT FOR JSTEP.') + DO 5299 I=1,NLEVEL + 5299 WRITE(6,631) + 1 (ABS(SIG((II-1)*NLEVEL+I+ISTART))*XJS,I,II,II=1,NLEVEL) + 5100 IF (XII.LE.DTOL .AND. XIJ.LE.OTOL) GO TO 5102 + IECONV(INRG)=MIN0(IECONV(INRG),0) + GO TO 5103 + 5102 IECONV(INRG)=IECONV(INRG)+1 + 5103 IF(KSAVE.GT.0) GO TO 6320 +C +C SAVE S MATRICES ON TAPE (ISAVEU) . . . + IF (IRSTRT.GT.0) GO TO 6500 + IF (ISAVEU.LE.0) GO TO 6500 +C BEGINNING IN VERSION 14 NOPEN IS WITH THE 'HEADER' RECORD + WRITE(ISAVEU) JTOT,INRG,ENERGY(INRG),IEXCH,WT,M,NOPEN +C WRITE(ISAVEU,803) JTOT,INRG,ENERGY(INRG),IEXCH,WT,M +C 803 FORMAT(2I4,E16.8,I4,E16.8,I4) + WRITE(ISAVEU) + 1 (J(NBASIS(I)),L(NBASIS(I)),WVEC(NBASIS(I)),I=1,NOPEN) +C WRITE(ISAVEU,804) NOPEN, +C 1 (J(NBASIS(I)),L(NBASIS(I)),WVEC(NBASIS(I)),I=1,NOPEN) +C 804 FORMAT(I4/(2I4,E16.8)) + CALL SWRITE(ISAVEU,NOPEN,SREAL) + CALL SWRITE(ISAVEU,NOPEN,SIMAG) +C NSQ=NOPEN*NOPEN +C WRITE(ISAVEU,805) (SREAL(I),I=1,NSQ) +C WRITE(ISAVEU,805) (SIMAG(I),I=1,NSQ) +C 805 FORMAT(5E16.8) + GO TO 6500 +C + 6320 IF(ISAVEU.LE.0) GO TO 6322 +C 'KSAVE' OUTPUT FORMAT *NOT* CHANGED + WRITE(ISAVEU) JTOT,INRG,ENERGY(INRG),IEXCH,WT,M + 6324 FORMAT(2I4,D22.15,I4,D22.15,I4) + WRITE(ISAVEU) NOPEN, + 1 (J(NBASIS(I)),L(NBASIS(I)),WVEC(NBASIS(I)),I=1,NOPEN) + 6326 FORMAT(I4/(2I4,D22.15)) + NPL1=NOPEN+1 + NSQ=NOPEN*NOPEN + WRITE(ISAVEU) (SREAL(I),SIMAG(I),I=1,NSQ,NPL1) + WRITE(ISAVEU) ((AKMAT(I,JJ),I=1,JJ),JJ=1,NOPEN) + 6328 FORMAT(4(D20.13)) + 6322 ESUM=EPSUM(AKMAT,NOPEN,SREAL,SIMAG,SREAL(NOPEN+1)) + IF(ISAVEU.GT.0) WRITE(ISAVEU) ESUM + WRITE(6,6342) ESUM + 6342 FORMAT('0 S-MATRIX EIGENPHASE SUM, EPSUM/PI =',F9.5) + IS=INRG-5*((INRG-1)/5) + EPSM(IS)=ESUM +C + WRITE(KSAVE,6330) JTOT,M,NOPEN,INRG,ENERGY(INRG),ESUM + 6330 FORMAT(1X,I3,2I4,I5,F18.10,F21.15) +C +C ENTRY TO ALLOW UPDATING OF SIG() ON UNIT ISIGU +C IN CASE THERE ARE NO BASIS FNS FOR SYMMETRY BLOCK M=MXPAR. + GO TO 6500 + ENTRY OUTSIG(ISIGU,M,MXPAR,INRG,ENERGY,MINJT,MAXJT,SIG) + IRET=1 +C +C UPDATE DISK (ISIGU) RECORD IF THIS IS THE LAST PARITY CASE + 6500 IF (.NOT.LOUT .OR. M.NE.MXPAR) GO TO 7200 + XJS=JSTEP + IJ=(INRG+1)*NSTOR + I10=ISST(INRG) + DO 7100 I=1,NLEVEL + DO 7100 II=1,NLEVEL + IJ=IJ+1 +C I10 IS INCREMENTED BY ASSOCIATED VARIABLE HERE. + IF (SIG(IJ).GE.0.D0) THEN + WRITE(ISIGU,101,REC=I10) STAR,ENERGY(INRG), + 1 MINJT(INRG),JSTEP,MAXJT(INRG),II,I,SIG(IJ)*XJS,BLANK + ELSE + WRITE(ISIGU,101,REC=I10) STAR,ENERGY(INRG), + 1 MINJT(INRG),JSTEP,MAXJT(INRG),II,I,ABS(SIG(IJ))*XJS,STAR + ENDIF + I10=I10+1 + 101 FORMAT(A1,F19.6,I5,2I7,5X,2I5,1P,D20.6,1X,A1) + 7100 CONTINUE + IF (PRINT.GT.1) WRITE(6,690) ISIGU,INRG,ENERGY(INRG),JTOT,M + 690 FORMAT(' OUTSIG: DA FILE (',I2,') UPDATED WITH SIGMA FOR ENERGY(' + 1 ,I3,') =',F10.2,' JTOT =',I4,'.',I2) +C +C>>SG(10/92) +C7200 CONTINUE + 7200 IF (IRET.EQ.1) RETURN +C< +C Date: Mon, 19 Jun 1995 12:48:11 +0200 (MET DST) +C Some mods 27-28 June 95 by SG for speed and to accord w/ MOLSCAT +C Bugs fixed 21 Sept 95 (SG) +C + IMPLICIT DOUBLE PRECISION(A-H,O-Z) +C +C CHECK FOR ABS(COSTH).LE.1.D0 ... + IF (ABS(COSTH).GT.1.D0) THEN + WRITE(6,*) ' *** ILLEGAL ARGUMENT TO PLM. X =',COSTH + STOP + ENDIF +C SAVE ARGUMENTS IN LOCAL VARIABLES + L=LIN + M=ABS(MIN) + X=COSTH +C +C IF M>L PLM=0 ! + IF(M.GT.L) THEN + PLM=0.D0 + RETURN + ENDIF + LMAX=L +C + IF (M.GT.0) GO TO 5 +C HERE FOR REGULAR LEGENDRE POLYNOMIALS + PLM=1.D0 + PM2=0.D0 + XL=0.D0 + DO 2 L=1,LMAX + XL=XL+1.D0 + PP=((2.D0*XL-1.D0)*X*PLM-(XL-1.D0)*PM2)/XL + PM2=PLM + 2 PLM=PP + GO TO 9000 +C +C HERE FOR ALEXANDER-LEGENDRE POLYNOMIALS +C + 5 IMAX=2*M + RAT=1.D0 + AI=0.D0 + DO 6 I=2,IMAX,2 + AI=AI+2.D0 + 6 RAT=RAT*((AI-1.D0)/AI) +C Y=SIN(THETA) + Y=SQRT(1.D0-X*X) + PLM=SQRT(RAT)*(Y**M) + PM2=0.D0 + LOW=M+1 + XL=LOW-1 + DO 10 L=LOW,LMAX + XL=XL+1.D0 + AL=DBLE((L+M)*(L-M)) + AL=1.D0/AL + AL2=(DBLE((L+M-1)*(L-M-1)))*AL + AL=SQRT(AL) + AL2=SQRT(AL2) + PP=(2.D0*XL-1.D0)*X*PLM*AL-PM2*AL2 + PM2=PLM + 10 PLM=PP + PLM=PLM*PARITY3(MIN) +C +C CONVERT TO MOLSCAT'S IDIOSYNCRATIC NORMALIZATION +9000 PLM=PLM*SQRT(XL+0.5D0) + RETURN + END + + SUBROUTINE POTENT (W, VECNOW, SCMAT, EIGNOW, HP, SCR, + 1 RNOW, DRNOW, EN, XLARGE, NCH, + 2 P, MXLAM, VL, IV, RMLMDA, ERED, EINT, CENT, NPOTL) +* ---------------------------------------------------------------------- +* THIS SUBROUTINE FIRST SETS UP THE WAVE-VECTOR MATRICES: +* W = W[RNOW + 0.5 DRNOW/SQRT(3)] AND W = W[RNOW - 0.5 DRNOW/SQRT(3)] +* B A +* THEN DIAGONALIZES THE AVERAGE; I.E. 0.5 (W + W ) +* B A +* THE RADIAL DERIVATIVE OF THE WAVEVECTOR MATRIX IS CALCULATED BY FINIT +* DIFFERENCE, USING THE NODES OF A TWO-POINT GAUSS-LEGENDRE QUADRATURE +* 1/2 +* D(W)/DR = 3 (W - W ) / DRNOW +* B A +* THIS IS THEN TRANSFORMED INTO THE LOCAL BASIS +* AUTHOR: MILLARD ALEXANDER +* CURRENT REVISION DATE: 25-SEPT-87 +* --------------------------------------------------------------------- +* VARIABLES IN CALL LIST: +* W: ON RETURN: CONTAINS TRANSFORM OF DH/DR +* THIS IS THE SAME AS THE NEGATIVE OF THE +* WN-TILDE-PRIME MATRIX +* VECNOW: ON RETURN: CONTAINS MATRIX OF EIGENVECTORS +* SCMAT: SCRATCH MATRIX +* EIGNOW: ON RETURN: CONTAINS EIGENVALUES OF WAVEVECTOR MATRIX +* HP: ON RETURN: CONTAINS DIAGONAL ELEMENTS OF TRANSFORMED DH/D +* THIS IS THE SAME AS THE NEGATIVE OF THE DIAGON +* ELEMENTS OF THE WN-TILDE-PRIME MATRIX +* SCR: SCRATCH VECTOR +* RNOW: MIDPOINT OF THE CURRENT INTERVAL +* DRNOW: WIDTH OF THE CURRENT INTERVAL +* EN: TOTAL ENERGY IN ATOMIC UNITS +* XLARGE: ON RETURN CONTAINS LARGEST OFF-DIAGONAL ELEMENT IN +* WN-TILDE-PRIME MATRIX +* NCH: NUMBER OF CHANNELS. SAME AS +* MAXIMUM ROW DIMENSION OF MATRICES AND MAXIMUM DIMENSION O +* VECTORS +* ---------------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +* REAL EIGNOW, HP, SCMAT, SCR, VECNOW, W +* REAL DRNOW, EN, FACT, HALF, ONE, RA, RB, RNOW, SQ3, XLARGE, XMIN1 + INTEGER ICOL, IERR, IONE, IPT, NCH, NCHM1, NCHP1, NROW +* SQUARE MATRICES (OF ROW DIMENSION NCH) + DIMENSION W(1), VECNOW(1), SCMAT(1) +* VECTORS DIMENSIONED AT LEAST NCH + DIMENSION EIGNOW(1), HP(1), SCR(1) +C + DIMENSION P(1),VL(1),IV(1),EINT(1),CENT(1) +C + DATA IONE / 1 / + DATA ONE, XMIN1, HALF, SQ3 /1.D0, -1.D0, 0.5D0, 1.732050807D0/ + NCHP1 = NCH + 1 + NCHM1 = NCH - 1 + RA = RNOW - 0.5 * DRNOW / SQ3 + RB = RNOW + 0.5 * DRNOW / SQ3 +* SCMAT IS USED TO STORE THE WAVEVECTOR MATRIX AT RB + CALL WAVMAT (W, NCH, RA, P, VL, IV, ERED, EINT, CENT, + 1 RMLMDA, SCR, MXLAM, NPOTL) + CALL WAVMAT (SCMAT, NCH, RB, P, VL, IV, ERED, EINT, CENT, + 1 RMLMDA, SCR, MXLAM, NPOTL) +* SINCE WAVMAT RETURNS NEGATIVE OF LOWER TRIANGLE OF W(R) MATRIX (EQ.(3 +* M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ..."), +* NEXT STATEMENTS CHANGE ITS SIGN + CALL DSCAL(NCH*NCH, XMIN1, W, 1) + CALL DSCAL(NCH*NCH, XMIN1, SCMAT, 1) +* NEXT LOOP STORES AVERAGE WAVEVECTOR MATRIX IN SCMAT AND DERIVATIVE OF +* HAMILTONIAN MATRIX, IN FREE BASIS, IN W + FACT = - SQ3 / DRNOW +* THE ADDITIONAL MINUS SIGN IN THE PRECEDING EXPRESSION IS INTRODUCED B +* DH/DR =-DW/DR; SEE EQ.(9) OF +* M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ..." + IPT = 1 + DO 105 ICOL = 1, NCH +* NROW IS THE NUMBER OF (DIAGONAL PLUS SUBDIAGONAL) ELEMENTS IN COLUMN +* IPT POINTS TO THE DIAGONAL ELEMENT IN COLUMN ICOL FOR A MATRIX STORED +* PACKED COLUMN FORM +* HP AND SCR ARE USED AS SCRATCH VECTORS HERE + NROW = NCH - ICOL + 1 + CALL DCOPY (NROW, SCMAT(IPT), 1, SCR, 1) + CALL DAXPY (NROW, ONE, W(IPT), 1, SCMAT(IPT), 1) + CALL DAXPY (NROW, XMIN1, W(IPT), 1, SCR, 1) + CALL DSCAL (NROW, HALF, SCMAT(IPT), 1) + CALL DSCAL (NROW, FACT, SCR, 1) + CALL DCOPY (NROW, SCR, 1, W(IPT), 1) + IPT = IPT + NCHP1 + 105 CONTINUE +* NEXT LOOP FILLS IN UPPER TRIANGLES OF W AND SCMAT + IF (NCH .GT. 1) THEN + IPT = 2 + DO 110 ICOL = 1, NCH -1 +* IPT POINTS TO THE FIRST SUBDIAGONAL ELEMENT IN COLUMN ICOL +* NROW IS THE NUMBER OF SUBDIAGONAL ELEMENTS IN COLUMN ICOL + NROW = NCH - ICOL + CALL DCOPY (NROW, W(IPT), 1, W(IPT + NCHM1), NCH) + CALL DCOPY (NROW, SCMAT(IPT), 1, SCMAT(IPT + NCHM1), NCH) + IPT = IPT + NCHP1 +110 CONTINUE + END IF +* ---------------------------------------------------------------------- +* DIAGONALIZE SCMAT AT RNOW AND TRANSPOSE MATRIX OF EIGENVECTORS +* AFTER TRANSPOSITION, THE VECNOW MATRIX IS IDENTICAL TO THE TN MATRIX +* OF EQ.(6) OF M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS .. + CALL F02ABF(SCMAT,NCH,NCH,EIGNOW,VECNOW,NCH,SCR,IERR) + IF (IERR .NE. 0) THEN + WRITE (6, 115) IERR +115 FORMAT (' *** IERR =',I3,' IN AIRPRP/POTENT/RS; ABORT ***') + WRITE (6, 120) (EIGNOW (I), I=1, NCH) +120 FORMAT (' EIGENVALUES ARE:',/,8(1PE16.8) ) + STOP + END IF +* TRANSFORM THE DERIVATIVE INTO THE LOCAL BASIS +* SUBROUTINE DTRANS RETURNS THE NEGATIVE OF THE WN-TILDE-PRIME MATRIX; +* EQ.(9) OF M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ..." + CALL TRNSFM(VECNOW, W, SCMAT, NCH, .FALSE., .TRUE.) + CALL TRNSP(VECNOW, NCH) + CALL DCOPY(NCH, W, NCH+1, HP, 1) +C +C FIND LARGEST OFF-DIAGONAL ELEMENT IN TRANSFORMED W +C + XLARGE=0.D0 + IPT=2 + DO 130 ICOL=1,NCH-1 + NCOL=NCH-ICOL + CALL MAXMGV (W(IPT), 1, ZABS, IC, NCOL) + IF(ZABS .GT. XLARGE) XLARGE=ZABS + IPT=IPT+NCH+1 +130 CONTINUE +C + RETURN + END + SUBROUTINE POTIN9(ITYPE,LAM,MXLAM,NPTS,NDIM,XPT,XWT,MXPT,X,MX, + 1 IXFAC) + DIMENSION XPT(MXPT,NDIM),XWT(MXPT,NDIM),NPTS(NDIM), + 1 LAM(MXLAM),X(MX) + WRITE(6,*) ' *** POTIN9 CALLED WITHOUT A SUITABLE USER-SUPPLIED', + 1 ' ROUTINE' + STOP + END + SUBROUTINE PRBR(JTOT,M,N,INRG,RM, + 1 NBASIS,LEV,L,WVEC,SREAL,SIMAG,IC,IL,IC1,IL1, + 2 JLEV,MXPAR,WGHT,PRINT,ILSU) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE +C +C *** AUG 76 NEW COUPLED STATES TREATMENT (KOURI ET AL.) +C *** JUL 86 (CCP6 VERSION 9) MOD 26 AUG 86 TO GET MXREC PROPERLY. +C *** AND MOD 21 OCT 86 : EDIFMX +C *** OCT 86 VERSION FOR 'OFF-DIAGONAL' CROSS SECTIONS +C *** JAN 87 CHANGES TO GET MPLMIN HANDLING CORRECT FOR ITYPE=25,26 +C *** AND ADD JSTEP TO ENTRY PRBOUT (REQUIRES CHANGE IN DRIVER) +C *** MAR 87 CORRECTIONS FOR ITYPE=26 +C *** DEC 88 INCLUDE ITYPE=7 AND Q=0 +C *** MAR 89 HAS 'IN-CORE' D.A. SIMULATION +C *** (NEED SUBROUTINE DASIZE/ENTRIES DARD1,DARD2,DAWR1,DAWR2) +C *** JUL 92 REMOVES ALL REFERENCES TO LCSOLD (OLD, INCORRECT, +C *** FORMULATION FOR COUPLED STATES: SEE, E.G., +C *** GREEN, ET AL. JCP, 66, 1409 (1977)) +C *** CALLS TO ENTRIES (IN PRBR3) ALSO HAVE BEEN TRAPPED THERE. +C *** JUN 93 FIXES BUG IN PRBR3 AND USES /MEMORY/ TO ELIMINATE LIMITS. +C *** AUG 94 V14: ENTRY PRBCNT ADDED AND COMMON CMBASE CHANGED +C +C CALCULATES SIGMA(JA1,JB1;JA,JB;K) +C WHERE A/B INDICATE INITIAL/FINAL SPECTRAL LINES, +C A1/B1 ARE AFTER COLLISION, AND K IS TENSOR ORDER +C SEE, E.G., SHAFER AND GORDON, JCP 58, 5422 (1973). +C +C SUPPOSED TO BE UPWARD COMPATIBLE IF LDIAG=.TRUE.: +C LDIAG=.TRUE. TAKES *OLD* INPUT LINE=LEVA,LEVB, LEVA,LEVB, ... , +C AND SETS LEVA1=LEVA, LEVB1=LEVB FOR ALL LINES. +C LDIAG=.FALSE. INPUT IS LINE=LEVA,LEVB,LEVA1,LEVB1, +C LEVA,LEVB,LEVA1,LEVB1, ... +C N.B. LDIAG FORCED TO TRUE FOR ITYPE=3 CALCULATIONS. +C +C ENTRY PRBRIN ACCEPTS &INPUT DATA AND SETS UP PRES. BROAD. CALC. +C ENTRY PRBOUT PRINTS OUT ACCUMULATED SIGR, SIGI. +C ENTRY PRBCNT FINDS WHETHER AN S-MATRIX WILL BE USED FOR PB CALC +C +C PRBR SPECIFICATIONS -------------------------------------- +C + DIMENSION NBASIS(1),LEV(1),L(1),IC(1),IL(1),IC1(1),IL1(1), + 1 JLEV(NLEV,NQN) + DIMENSION WVEC(1),SREAL(1),SIMAG(1) +C +C JTOT IS TOTAL ANGULAR MOMENTUM +C M = 0 FOR LAST PARITY STEP AT THIS JTOT. +C N IS NUMBER OF OPEN CHANNELS, DETERMINES DIMENSION OF VECTORS. +C INRG IS INDEX FOR ENERGY VALUES +C RM IS SCALING FACTOR FOR RADIAL WAVEFUNCTION. +C NBASIS (I) POINTS TO LEV,L VALUES FOR ITH OPEN CHANNEL. +C LEV IS VECTOR OF BASIS SET LEVELS +C L IS VECTOR OF BASIS ORBITAL ANGULAR MOMENTA. +C WVEC IS VECTOR OF WAVEVECTORS +C SREAL(N,N) IS REAL PART OF S MATRIX. +C SIMAG(N,N) IS IMAGINARY PART OF S MATRIX. +C + LOGICAL ITYPE3,EPM,LCSNEW,MPLMIN,LCSSYM + INTEGER JT(2) +C +C PRBRIN SPECIFICATIONS ------------------------------------ +C + INTEGER NLPRBR,MXLN,LINE(MXLN),ILSU,NNRG,PRINT,MXNRG,IFEGEN + INTEGER T(MXLN) + DIMENSION ENERGY(NNRG) +C +C NLPRBR =0 FOR NO LINE SHAPE CALC. +C =N (GT.0) GIVES NO. OF LINES FOR WHICH TO COMPUTE L.S. +C LINE(4*I-3),... ,I=1,NLPRBR IS LEVEL DATA FOR LINES. +C ILSU (NOW REDUNDANT) WAS DIRECT ACCESS FILE FOR WORKING STORAGE +C ENERGY(NNRG) ARE ENERGIES AT WHICH S MATRIX IS CALCULATED. +C MXNRG IS MAXIMUM DIMENSION OF ENERGY ARRAY +C IFEGEN .GT. 0 REQUESTS GENERATION OF ADDITIONAL ENERGY VALUES. +C PRINT IS INTEGER PRINT CONTROL. +C + LOGICAL NOCALC,PF,NDEBUG + LOGICAL LDIAG,EXISTS,LDIAGX + CHARACTER*8 PTP(3) +C STORAGE DIMENSIONED FOR NO. OF LINES = MAXLN. + DIMENSION LN(400,9) + DIMENSION EREL(400),SIGR(400),SIGI(400) + DIMENSION P(2),PRTY(4) +C +C INFORMATION ORIGINALLY PASSED AS ENTRY PRBRBS, NOW IN COMMON +C + COMMON /CMBASE/ ROTI(12),ELEVEL(1000),EMAX,WT(2),SPNUC, + 1 NLEVEL,JLEVEL(4000),MISC(26),JHALF,IDENT,MXJL,MXEL + COMMON /PRBASE/ ITYPE,NQN,NLEV,MVALUE,IEXCH,MPLMIN + COMMON /ASSVAR/ IDA +C +C NLEV AND NLEVEL ARE NO. OF LEVELS IN BASIS SET. +C JLEV AND JLEVEL ARE QUANTUM NUMBERS FOR THESE LEVELS. +C ELEVEL ARE ENERGIES OF THESE LEVELS. +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C +C --- DATA INITIALIZATIONS --- +C + DATA PTP/' Q = 0 ',' DIPOLE ',' RAMAN '/ + DATA P/1.D0,-1.D0/, PRTY/1.D0,-1.D0,-1.D0,1.D0/ +C *** BELOW REPLACES JMH'S CRITERION OF 1.D-10 FOR ENERGY DIFFERENCE +C *** SMALLER VALUE MAY BE NEEDED FOR RESONANCE CALCULATIONS. + DATA EDIFMX/5.D-6/ +C FOR COMPATBILITY WITH OLD INPUT, SET LDIAG=.TRUE. + DATA LDIAGX/.FALSE./ +C IF NDEBUG .EQ. .FALSE. CHECK FOR 'IMPOSSIBLE' NUMBERS OF MATCHES. + DATA NDEBUG/.FALSE./ +C DIMENSION LIMITATION ... + DATA MAXLN/400/ +C FOR CHECKING OVER-WRITE OF "DA FILE" + DATA JCHKSV/-1/ +C +C STATEMENT FUNCTION (LOGICAL) + EXISTS(I) = I.GT.0 .AND. I.LE.NLEVEL +C +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +C + IF (NOCALC) RETURN + IF (JCHKSV.EQ.-1) JCHKSV=JTOT + DO 3000 IA=1,2 +C IA=1 CHECKS FOR USE OF THIS JTOT,INRG WITH J(ALPHA). +C IA=2 FOR J(BETA). + IB=3-IA +C FIND LINES, I, WHICH USE THIS INRG, JTOT S MATRIX. + IKEEP=0 + DO 3100 I=1,NLINE + IF (LN(I,IA+3).NE.INRG) GO TO 3100 + K=LN(I,3) + JDIFMX=K + IF (LCSNEW) JDIFMX=0 + JDM=MAX(JDM,JDIFMX) + IF (ITYPE3) GO TO 3211 +C FOR ITYPE=1,2,5 GET J-VALUE FROM 1ST COL OF JLEV. + JA=JLEV(LN(I,1),1) + JB=JLEV(LN(I,2),1) + JA1=JLEV(LN(I,8),1) + JB1=JLEV(LN(I,9),1) +C PARITY FACTOR FOR CS WITH MPLMIN; THIS IS NORMALLY +1. + F3PJ=PARITY3(JA+JA1+JB+JB1) +C FIND BASIS FNS. CORRESPONDING TO JA/JA1 (JB/JB1) AND GET L VALUES. +C ROWS=>JA1,IC1,IL1 COLS=>JA,IC,IL +C FOR DIAG CASE (JA=JA1), IC/IC1 AND IL/IL1 HAVE SAME VALUES. + NLVAL=0 + NLVAL1=0 + DO 3200 II=1,N + JJ=NBASIS(II) + IF (LEV(JJ).NE.LN(I,IA)) GO TO 3201 + NLVAL=NLVAL+1 + IC(NLVAL)=II + IL(NLVAL)=L(JJ) + 3201 IF (LEV(JJ).NE.LN(I,IA+7)) GO TO 3200 + NLVAL1=NLVAL1+1 + IC1(NLVAL1)=II + IL1(NLVAL1)=L(JJ) + 3200 CONTINUE + GO TO 3212 +C +C FOR ITYPE=3 GET J-VALUE FROM JLEVEL. RECALL J1,J2 PACKED IN ORDER +C + 3211 JA=JLEVEL(2*LN(I,1)-1) + JB=JLEVEL(2*LN(I,2)-1) +C BELOW MAY BE NEEDED FOR COMPATIBILITY IN OFF-DIAG CODE + JA1=JA + JB1=JB +C ALLOCATE TEMPORARY STORAGE FOR SR,SI,TR,JBAR,ISTB,NBLK,LVAL + NSQ=N*N + NINT=(N+NIPR-1)/NIPR + IT1=IXNEXT + IT2=IT1+NSQ + IT3=IT2+NSQ + IT4=IT3+NSQ + IT5=IT4+NINT + IT6=IT5+NINT + IT7=IT6+NINT + IXNEXT=IT7+NINT +C WRITE(6,*) ' IT1-IT7,IXNEXT',IT1,IT2,IT3,IT4,IT5,IT6,IT7,IXNEXT + NUSED=0 + CALL CHKSTR(NUSED) + CALL PRBR3(N,SREAL,SIMAG,JTOT,NLEV,NQN,JLEV,NBASIS,LEV,L,NPACK, + 1 LN(I,IA),NLVAL,IC,IL, + 2 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5),X(IT6),X(IT7)) +C N.B. ONLY SR,SI NEED TO BE KEPT, IXNEXT COULD BE REDUCED HERE ... +C IXNEXT=IT3 +C>>SG 1 JUN 93: NLVAL1,IL1,IC1 MUST BE ALSO BE SET (CF. DIAGONAL CASE). + NLVAL1=NLVAL + DO 3311 II=1,NLVAL + IL1(II)=IL(II) + 3311 IC1(II)=IC(II) +C< RMID. THE CONSTANT-STEP METHOD IS RECOMMENDED BY +C ANDERSON, J.CHEM.PHYS. 77,4431(1982). +C VTOL IS A TOLERANCE PARAMETER FOR THE LARGEST OFF-DIAGONAL +C ELEMENT OF THE TRANSFORMATION MATRIX, USED TO DECIDE WHEN TO +C STOP INTEGRATING. +C FACT AND DRMAX ARE NOT USED IN THIS VERSION. +C +C ISTART IS 0 IF THE R-MATRIX IS TO BE INITIALISED +C 1 IF THE R-MATRIX (FROM L2 CALC) IS ALREADY IN R +C +C ---------------------------------------------------------------- +C SET UP TO USE UNIT (ISCRU) + IREAD = ICODE.EQ.2 .AND. ISCRU.GT.0 + IWRITE = ICODE.EQ.1 .AND. ISCRU.GT.0 +C --------------------------------------------------------------- +C + N=NBAS + NSQ=NSQBAS + GOTTP=.FALSE. + IF(XEPS.LE.0.D0 .OR. ISCRU.LE.0) GOTO 100 + IF (IVLFL.NE.0) THEN + IF(IWRITE) WRITE(ISCRU) JJ,L,EINT,CENT,VL,IV + IF(IREAD) READ (ISCRU) JJ,L,EINT,CENT,VL,IV + ELSE + IF(IWRITE) WRITE(ISCRU) JJ,L,EINT,CENT,VL + IF(IREAD) READ (ISCRU) JJ,L,EINT,CENT,VL + ENDIF +C +C COUNT NUMBER OF OPEN CHANNELS AND SET UP WVEC ARRAY. +C + 100 NOPEN=0 + DO 110 I=1,N + DIF=ERED-EINT(I) + WVEC(I)=SIGN(SQRT(ABS(DIF)),DIF) + IF(DIF.LE.0.D0) GOTO 110 + NOPEN=NOPEN+1 + 110 CONTINUE +C +C IF THERE ARE NO OPEN CHANNELS RETURN +C + IF(NOPEN.EQ.0) RETURN + NOPSQ=NOPEN*NOPEN +C +C SORT CHANNELS BY ASYMPTOTIC ENERGY +C + DO 120 I=1,N + CLOSE(I)=0.D0 + 120 NB(I)=I + IF(N.LE.1) GOTO 140 + NM1=N-1 + DO 130 I=1,NM1 + IP1=I+1 + DO 130 J=IP1,N + IF(EINT(NB(I)).LE.EINT(NB(J))) GOTO 130 + IT=NB(I) + NB(I)=NB(J) + NB(J)=IT + 130 CONTINUE + 140 CONTINUE +C +C ICODE=1/2 MEANS PROPAGATION ISN'T/IS TO BE DONE WITH STORED DATA +C + IF(ICODE.EQ.1 .AND. PRINT.GE.2) WRITE(6,150) RMIN + 150 FORMAT('0 START R-MATRIX PROPAGATOR AT RMIN =',F8.5) + IF(PRINT.GE.15 .AND. ICODE.EQ.1) WRITE(6,160) + 160 FORMAT('0 KSTEP RNOW EIGVAL(1) EIGVAL(N)'/) +C +C CALCULATE R-MATRIX AT FIRST STEP. +C + IF(IREAD) GOTO 170 + RNOW=RMIN + IF(ISTART.EQ.0) RNOW=RNOW+0.5D0*DR + DRNOW=DR + DRNEW=DRNOW + KSTP=1 + CALL WAVMAT(W,NBAS,RNOW,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, + 1 MXLAM,NPOTL) + IFAIL=0 + CALL F02ABF(W,NBAS,NBAS,EIGOLD,SI,NBAS,R1,IFAIL) + IF(ISCRU.LE.0) GOTO 190 + WRITE(ISCRU) RNOW,DRNOW + WRITE(ISCRU) KSTP,EIGOLD + WRITE(ISCRU) DRNEW + GOTO 190 +C + 170 READ(ISCRU) RNOW,DRNOW + READ(ISCRU) KSTP,EIGOLD + READ(ISCRU) DRNEW + DO 180 I=1,N + EIGOLD(I)=EIGOLD(I)-ESHIFT + 180 CONTINUE +C + 190 IF(ISTART.NE.0) GOTO 220 +C +C NO INITIAL R-MATRIX SUPPLIED. INITIALISE IT. +C + DO 200 I=1,NSQ + 200 R(I)=0.D0 + IND=-N + DO 210 I=1,N + IND=IND+N+1 + R(IND)=1.D0/SQRT(ABS(EIGOLD(I))) + 210 CONTINUE + GOTO 230 +C +C TRANSFORM SUPPLIED R-MATRIX TO LOCAL BASIS +C + 220 CALL TRNSFM(SI,R,Q,N,.FALSE.,.TRUE.) +C + 230 ITRY=-1 + DLAST=1.D36 +C +C PROPAGATE R-MATRIX +C + DO 430 KSTEP=2,MAXSTP + NOLD=N + ROLD=RNOW + RNOW=RNOW+0.5D0*(DRNOW+DRNEW) + DRNOW=DRNEW + IF(.NOT.IREAD) GOTO 250 +C +C IF ICODE = 2 READ EIGNOW AND Q MATRIX FROM DISK +C + READ(ISCRU) KSTP,EIGNOW,Q + DO 240 I=1,N + EIGNOW(I)=EIGNOW(I)-ESHIFT + 240 CONTINUE + GOTO 290 +C +C IF ICODE = 1 CALCULATE EIGNOW AND Q MATRIX +C + 250 CALL WAVMAT(W,N,RNOW,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, + 1 MXLAM,NPOTL) + IF(XEPS.LE.0.D0 .OR. GOTTP) GOTO 270 +C +C LOOK FOR TURNING POINT OR POTENTIAL MINIMUM IN LOWEST-LYING +C CHANNEL (WHICHEVER OCCURS AT SMALLEST R). +C SAVE INFORMATION FOR USE IN NEXT CALL TO RMSET. +C + IF(DIAG(IK).GT.0.D0.AND.DIAG(IK).LT.DLAST) GOTO 260 + GOTTP=.TRUE. + RTURN=RNOW + 260 DLAST=DIAG(IK) +C + 270 IFAIL=0 + CALL F02ABF(W,N,N,EIGNOW,SR,N,R1,IFAIL) + CALL SGNCHK(SI,SR,N) + CALL DGEMUL(SI,N,'T',SR,N,'N',Q,N,N,N,N) + IF(ISCRU.GT.0) WRITE(ISCRU) KSTEP,EIGNOW,Q + DO 280 I=1,NSQ + 280 SI(I)=SR(I) + 290 CONTINUE +C +C IF(KSTEP.GT.2) GOTO 213 +C +C CALCULATE PROPAGATOR FOR R-MATRIX. +C + NOPLOC=0 + DO 320 I=1,N + EIG=EIGNOW(I) + FLAM=SQRT(ABS(EIG)) + IF(EIG.GE.0.D0) GOTO 300 + R1(I) = -1.D0/(FLAM*TAN(DRNEW*FLAM)) + R2(I) = -1.D0/(FLAM*SIN(DRNEW*FLAM)) + NOPLOC=NOPLOC+1 + GOTO 310 + 300 R1(I) = 1.D0/(FLAM*TANH(DRNEW*FLAM)) + R2(I) = 1.D0/(FLAM*SINH(DRNEW*FLAM)) + IF(RNOW.GT.1.5D0*RTURN) CLOSE(I)=CLOSE(I)+DRNEW*FLAM + 310 R3(I) = R2(I) + R4(I) = R1(I) + 320 CONTINUE +C + CALL TRNSFM(Q,R,SR,N,.FALSE.,.TRUE.) +C + IND=-N + DO 330 I=1,N + IND=IND+N+1 + R(IND)=R(IND)+R1(I) + 330 CONTINUE + CALL SYMINV(R,N,N,IFAIL) + IF(IFAIL.GT.N) GOTO 480 + CALL DSYFIL('U',N,R,N) + IND=0 + DO 340 IC=1,N + DO 340 IR=1,N + IND=IND+1 + R(IND)=-R3(IR)*R(IND)*R2(IC) + 340 CONTINUE + IND=-N + DO 350 I=1,N + IND=IND+N+1 + R(IND)=R(IND)+R4(I) + 350 CONTINUE + IF(IREAD) GOTO 400 +C +C IF ICODE=1 COMPUTE NEW STEP SIZE AND TEST FOR END OF PROPAGATION. +C + DRNEW=DR*RNOW/RMID + IF(DRNEW.LT.DR) DRNEW=DR +C + DO 360 I=1,N + EIGOLD(I)=EIGNOW(I) + 360 CONTINUE +C +C SEE IF OFF-DIAG ELEMENTS OF SI ARE SMALL ENOUGH. +C + CALL COLIM(SI,R1,R2,VTOL,N) + CALL STRY(R1,R2,N,ITRY,EIGOLD) + IF(ITRY.NE.1) GOTO 380 + RUP=RNOW+DRNOW/2.D0 + IF(RUP.GE.RMAX .AND. NOPLOC.GE.NOPEN) GOTO 370 + ITRY=0 + GOTO 380 + 370 IF(ISCRU.LE.0) GOTO 450 + DRNEW=-9999.D0 + WRITE(ISCRU) DRNEW + WRITE(ISCRU) SI + GOTO 450 + 380 IF(ISCRU.GT.0) WRITE(ISCRU) DRNEW + EIG1=(ERED+EIGOLD(1))/RMLMDA + EIGN=(ERED+EIGOLD(N))/RMLMDA + IF(PRINT.GE.15) WRITE(6,390) KSTEP,RNOW,EIG1,EIGN + 390 FORMAT(1X,I7,F11.5,2(1PD16.6)) + GOTO 410 +C +C IF ICODE=2 READ NEW STEP SIZE FROM DISK +C + 400 READ(ISCRU) DRNEW + IF(DRNEW.NE.-9999.D0) GOTO 410 + READ(ISCRU) SI + GOTO 450 +C + 410 CNTRCT=XEPS.GT.0.D0 .AND. N.GT.NOPMAX .AND. CLOSE(N).GT.DEEP + IF(IWRITE) WRITE(ISCRU) CLOSE,CNTRCT + IF(IREAD) READ (ISCRU) CLOSE,CNTRCT + IF (CNTRCT) + 1 CALL SHRINK(ICODE,RNOW,W,N,VL,IV,NB,JJ,L,EINT,CENT,WVEC, + 2 CLOSE,SI,EIGOLD,R,SR,DEEP,NSQ,NPOTL,ISCRU,NOPMAX,PRINT) + 430 CONTINUE +C +C END OF R-MATRIX PROPAGATION LOOP +C + WRITE(6,440) + 440 FORMAT('0***** ERROR IN RMTPRP - LIMIT OF',I7,'STEPS REACHED.', + 1 ' RUN HALTED.') + STOP +C +C REACH HERE WHEN ASYMPTOTIC REGION IS REACHED +C + 450 CALL TRNSP(SI,N) + CALL TRNSFM(SI,R,SR,N,.FALSE.,.TRUE.) +C + RUP=RNOW+DRNOW/2.D0 + IF(ICODE.EQ.1 .AND. PRINT.GE.2) + 1 WRITE(6,460) RUP,KSTEP + 460 FORMAT(' FINISHED AT RUP =',F10.5,' AFTER',I7,' STEPS') + IF(ICODE.NE.1 .AND. PRINT.GE.5) WRITE(6,470) + 470 FORMAT('0 R-MATRIX PROPAGATION COMPLETED USING STORED DATA') +C + CALL SYMINV(R,N,N,IFAIL) + IF(IFAIL.GT.N) GOTO 480 + CALL YTOK(NB,WVEC,L,N,NOPEN,R1,R2,R3,R4,R,SR,Q,RUP) + CALL KTOS(Q,SR,SI,NOPEN) + RETURN +C + 480 WRITE(6,490) + 490 FORMAT('0***** ERROR IN SYMINV CALLED FROM RMTPRP.', + 1 ' RUN HALTED.') + STOP + END + SUBROUTINE RSYM(NN,R,STEST,PRINT) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + INTEGER PRINT + DIMENSION R(NN,NN) + IF (NN.LE.1) RETURN + NERR=0 + XX=0.D0 + TEST=MAX(STEST,5.D-7) + DO 1200 I=2,NN + IM1=I-1 + DO 1200 J=1,IM1 + SUM=R(I,J)+R(J,I) + ASUM=ABS(SUM) + ADIF=ABS(R(I,J)-R(J,I)) + IF (ASUM.LE.TEST) GO TO 1100 + RAT=ADIF + IF (ASUM.GE.2.D0) RAT=RAT/ASUM + IF (RAT.LE.TEST) GO TO 1100 + XX=MAX(XX,RAT) + NERR=NERR+1 + 1100 SUM=.5D0*SUM + R(I,J)=SUM + 1200 R(J,I)=SUM + IF (NERR.LE.0) RETURN + NO=NN*(NN-1)/2 + IF(PRINT.GE.4) WRITE(6,601) NERR,NO,TEST,XX + 601 FORMAT(I6,' OF',I4,' OFF-DIAGONAL ELEMENTS OF ', + & 'K-MATRIX NOT SYMMETRIC WITH RESPECT TO TEST =',2D12.4) + RETURN + END + FUNCTION RSYMTP(J1,K1,J2,J1P,K1P,J2P,JJ,JJP,MU,P1,Q1,P2,PP) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + INTEGER P1,Q1,P2,PP + DATA Z0/0.D0/, PI/3.14159265358979289D0/ +C STATEMENT FUNCTION . . . + Z(X)=2.D0*X+1.D0 +C + XJ1 = J1 + XK1 = K1 + XJ2 = J2 + XJ1P = J1P + XK1P = K1P + XJ2P = J2P + XJJ = JJ + XJJP = JJP + XMU = MU + XQ1 = Q1 + XP1 = P1 + XP2 = P2 + XPP = PP + RSYMTP=0.D0 + F=THRJ(XJ1,XP1,XJ1P,-XK1,XQ1,XK1P) + IF (ABS(F) .LE. 1.D-8) RETURN + F=F*THRJ(XJJ,XPP,XJJP,XMU,Z0,-XMU) + IF (ABS(F) .LE. 1.D-8) RETURN + F = F*THREEJ(J2,P2,J2P) + IF(ABS(F) .LE. 1.D-8) RETURN + F = F*XNINEJ(JJ,PP,JJP,J1,P1,J1P,J2,P2,J2P) + IF(ABS(F) .LE. 1.D-8) RETURN + RSYMTP=F*SQRT(Z(XJ1)*Z(XJ1P)*Z(XJ2)*Z(XJ2P)*Z(XPP)*Z(XP2) + 1 *Z(XJJ)*Z(XJJP))*PARITY3(J1P+J2P+JJ+MU-K1)/(4.0D0*PI) + RETURN + END +* ---------------------------------------------------------------------- + SUBROUTINE SCAIRY (Z, SCAI, SCBI, SCAIP, SCBIP, ZETA) +* SCALED AIRY FUNCTIONS AND DERIVATIVES +* THIS PROGRAM WRITTEN BY D.E. MANOLOPOULOS (SEPT. 1986) +* CURRENT REVISION DATE: SEPT-1986 +* ---------------------------------------------------------------- +* FOR Z .LT. (-5.0D0) +* AI(Z) = SCAI*COS(ZETA) + SCBI*SIN(ZETA) +* BI(Z) = SCBI*COS(ZETA) - SCAI*SIN(ZETA) +* AI'(Z) = SCAIP*COS(ZETA) + SCBIP*SIN(ZETA) +* BI'(Z) = SCBIP*COS(ZETA) - SCAIP*SIN(ZETA) +* WHERE ZETA = (2/3)*(-Z)**(3/2) + PI/4 +* FOR (-5.0D0) .LE. Z .LE. (+0.0D0) +* AI(Z) = SCAI +* BI(Z) = SCBI +* AI'(Z) = SCAIP +* BI'(Z) = SCBIP +* AND ZETA = 0 +* FOR (+0.0D0) .LT. Z +* AI(Z) = SCAI*EXP(-ZETA) +* BI(Z) = SCBI*EXP(+ZETA) +* AI'(Z) = SCAIP*EXP(-ZETA) +* BI'(Z) = SCBIP*EXP(+ZETA) +* WHERE ZETA = (2/3)*(+Z)**(3/2) +* ---------------------------------------------------------------- +* EVALUATION OF THE FUNCTIONS IS BASED ON A NUMBER OF +* CHEBYSHEV EXPANSIONS +* +* THIS VERSION IS SUITABLE FOR MACHINES WITH FULL WORD PRECISION +* ---------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DOUBLE PRECISION A, B, C, C1, C2, DF, DG, EX, EXP1Z, EXP2Z, F, + : G, PIB4, ROOT4Z, ROOTZ, RT3, SCAI, SCAIP, SCBI, + : SCBIP, T, T2, XEPS, Y, Z, ZCUBE, ZETA, ZSQ + DATA C1 / 3.55028053887817239D-01 / + DATA C2 / 2.58819403792806798D-01 / + DATA RT3 / 1.73205080756887729D+00 / + DATA PIB4 / 7.85398163397448310D-01 / + ZETA = 0.0D0 + XEPS = 0.0D0 +* ---------------------------------------------------------------------- +* HERE IF NEAR ENOUGH ORIGIN TO USE 3 TERM POWER SERIES + IF ( ABS(Z) .LE. 0.025D0) THEN + ZSQ = Z * Z + ZCUBE = ZSQ * Z +* EVALUATE POWER SERIES ( THREE TERMS IS SUFFICIENT FOR ABS(X) < 0.025) + DF = 1.D0 + ZCUBE / 6.D0 + ZCUBE * ZCUBE / 180.D0 + DG = Z * (1.D0 + ZCUBE / 12.D0 + ZCUBE * ZCUBE / 504.D0) + SCAI = C1 * DF - C2 * DG + SCBI = RT3 * (C1 * DF + C2 * DG) +* NOW FOR DERIVATIVES + DF = ZSQ / 2.D0 + ZSQ * ZCUBE / 30.D0 + DG = 1.D0 + ZCUBE / 3.D0 + ZCUBE * ZCUBE / 72.D0 + SCAIP = C1 * DF - C2 * DG + SCBIP = RT3 * (C1 * DF + C2 * DG) +* SCALE THE FUNCTIONS BY EXP(ZETA) IF Z .GT. 0 + IF (Z .GT. 0.D0) THEN + ROOTZ = SQRT(Z) + ZETA = 2.0D0 * Z * ROOTZ / 3.0D0 + EX = EXP(ZETA) + SCAI = SCAI * EX + SCAIP = SCAIP * EX + SCBI = SCBI / EX + SCBIP = SCBIP / EX + END IF + RETURN + END IF + IF (Z.LT.(+9.0D0)) GO TO 10 + ROOTZ = SQRT(Z) + ROOT4Z = SQRT(ROOTZ) + ZETA = 2.0D0*Z*ROOTZ/3.0D0 + T = 36.0D0/ZETA - 1.0D0 + Y = ((((((((( +1.16537795324979200D-15*T + * -1.16414171455572480D-14)*T +1.25420655508401920D-13)*T + * -1.55860414100340659D-12)*T +2.21045776110011276D-11)*T + * -3.67472827517194031D-10)*T +7.44830865396606612D-09)*T + * -1.95743559326380581D-07)*T +7.44672431969805149D-06)*T + * -5.28651881409929932D-04)*T +2.81558489585006298D-01 + SCAI = Y/ROOT4Z + Y = ((((((((((( +4.50165999254528000D-15*T + * +1.56232018374502400D-14)*T +5.26240712559918080D-14)*T + * +2.97814898856618752D-13)*T +1.97577620975625677D-12)*T + * +1.53678944110742706D-11)*T +1.45409933537455235D-10)*T + * +1.71547326972380087D-09)*T +2.61898617129147064D-08)*T + * +5.49497993491833009D-07)*T +1.76719804365109334D-05)*T + * +1.12212109935874117D-03)*T +5.65294557558522063D-01 + SCBI = Y/ROOT4Z + Y = ((((((((( +1.20954638924697600D-15*T + * -1.21281218539020800D-14)*T +1.31303723724964224D-13)*T + * -1.64152781754533677D-12)*T +2.34672185025709461D-11)*T + * -3.94507329122119338D-10)*T +8.13125005420910243D-09)*T + * -2.19736365932356533D-07)*T +8.83993515227257822D-06)*T + * -7.43456339972080231D-04)*T -2.82847316336379200D-01 + SCAIP = Y*ROOT4Z + Y = ((((((((((( -4.59170437029478400D-15*T + * -1.59840960512122880D-14)*T -5.41258863340784640D-14)*T + * -3.07414589507261184D-13)*T -2.04866616770522650D-12)*T + * -1.60321415915690897D-11)*T -1.52922073861488292D-10)*T + * -1.82445639488695332D-09)*T -2.83250890588806503D-08)*T + * -6.11130377639012647D-07)*T -2.07842147963678572D-05)*T + * -1.56350017663858255D-03)*T +5.62646283094843014D-01 + SCBIP = Y*ROOT4Z + RETURN + 10 IF (Z.LT.(+4.5D0)) GO TO 20 + ROOTZ = SQRT(Z) + ZETA = 2.0D0*Z*ROOTZ/3.0D0 + EXP1Z = EXP(ZETA-2.5D0*Z) + EXP2Z = EXP(ZETA-2.625D0*Z) + T = 4.0D0*Z/9.0D0 - 3.0D0 + Y = ((((((((((((((((((((( +9.69081960415394529D-11*T + * +3.24436136050920784D-10)*T -3.57419513430644674D-09)*T + * -3.84461320827974687D-09)*T +8.88116699085949212D-08)*T + * -6.26105174374717557D-08)*T -1.69051051004298110D-06)*T + * +3.80731416363041759D-06)*T +2.43840529113057777D-05)*T + * -9.74379632673654766D-05)*T -2.45324254437931970D-04)*T + * +1.69517926953312785D-03)*T +1.19638433540225211D-03)*T + * -2.15255594590357451D-02)*T +9.33777073522844198D-03)*T + * +1.98716159257796883D-01)*T -2.54001858882057718D-01)*T + * -1.27148775197878180D+00)*T +2.52046376168394778D+00)*T + * +5.04987271423387057D+00)*T -1.33120978544419281D+01)*T + * -9.34903846550381088D+00)*T +3.10330812950257837D+01 + SCAI = Y*EXP1Z + Y = (((((((((((((((((((((((( +3.79210935744593920D-14*T + * -4.16346635040194560D-14)*T -3.63110681886588928D-13)*T + * +1.38932592029414195D-12)*T -4.00489068810888806D-12)*T + * +1.39019501834951721D-11)*T -4.50877182237241508D-11)*T + * +1.38942309844733264D-10)*T -3.92503498108710093D-10)*T + * +1.20125005161756928D-09)*T -3.14234550677825531D-09)*T + * +1.03100587323694771D-08)*T -2.35240060783126760D-08)*T + * +8.98525670958611253D-08)*T -1.57273011181242048D-07)*T + * +7.77696763289738864D-07)*T -8.40211181188135235D-07)*T + * +6.34887361301864569D-06)*T -2.73464023289055762D-06)*T + * +4.54606729925166230D-05)*T +2.20459155042947089D-06)*T + * +2.58823388957588056D-04)*T +7.31023768389466446D-05)*T + * +1.01013806904596356D-03)*T +2.64794416332118755D-04)*T + * +1.97499785553709145D-03 + SCBI = Y/EXP1Z + Y = ((((((((((((((((((((( -4.40679918437492851D-10*T + * +1.30954945449348301D-10)*T +1.30052079376596751D-08)*T + * -2.21315827945437064D-08)*T -2.56850909380644963D-07)*T + * +8.66960855365698346D-07)*T +3.75622307499741911D-06)*T + * -2.15396233361107222D-05)*T -3.55804094667597110D-05)*T + * +3.95317852914037711D-04)*T +5.03369361986934094D-05)*T + * -5.54634417403436820D-03)*T +5.29658186908372832D-03)*T + * +5.91311623537658225D-02)*T -1.09446664596286554D-01)*T + * -4.63589435529194219D-01)*T +1.25323269822030972D+00)*T + * +2.50138108959469254D+00)*T -9.12668774193995449D+00)*T + * -8.14385732036876466D+00)*T +4.00134082550833019D+01)*T + * +1.15396202931444799D+01)*T -8.17378314444550419D+01 + SCAIP = Y*EXP1Z + Y = (((((((((((((((((((((((( -1.12976379481423872D-13*T + * +2.84163275199873024D-13)*T +9.21367859618119680D-14)*T + * -6.47465116933029888D-13)*T +5.66210442158931968D-13)*T + * -3.03158042458901709D-12)*T +1.32640217809876419D-11)*T + * -3.03558223041639219D-11)*T +5.32290407073565901D-11)*T + * +1.67561690905544950D-11)*T -3.35234276365918044D-10)*T + * +2.92807773020050397D-09)*T -8.76900994127464369D-09)*T + * +4.69138029321003869D-08)*T -1.00929917942876779D-07)*T + * +5.40401934648687824D-07)*T -8.19977129258456927D-07)*T + * +5.13367651438974580D-06)*T -4.77800617725922708D-06)*T + * +4.02415391117897098D-05)*T -1.74571192912274417D-05)*T + * +2.45332091645215217D-04)*T -2.22916383050374016D-05)*T + * +1.02535993549737948D-03)*T +5.94033287658300975D-05)*T + * +2.17420627539345627D-03 + SCBIP = Y/EXP2Z + RETURN + 20 IF (Z.LE.(+0.0D0)) GO TO 40 + ROOTZ = SQRT(Z) + ZETA = 2.0D0*Z*ROOTZ/3.0D0 + EXP1Z = EXP(ZETA-1.5D0*Z) + EXP2Z = EXP(ZETA-1.375D0*Z) + T = 4.0D0*Z/9.0D0 - 1.0D0 + IF (Z.LT.(+XEPS)) GO TO 30 + Y = ((((((((((((((((((((((( +4.97635854909020570D-12*T + * -3.25024150273916928D-11)*T -5.15773946723072737D-11)*T + * +8.66802872160017711D-10)*T -9.51292671519803048D-10)*T + * -1.33268133924677102D-08)*T +4.37061406144179625D-08)*T + * +1.18943714086308365D-07)*T -8.66980482244589319D-07)*T + * -2.46768077494905499D-08)*T +1.10610939830483627D-05)*T + * -1.80475663535516462D-05)*T -9.22213518989192294D-05)*T + * +3.15767712665407001D-04)*T +4.08626419412850994D-04)*T + * -3.12704269924340764D-03)*T +6.27899244118607949D-04)*T + * +1.99062142478229001D-02)*T -2.27427058211322122D-02)*T + * -7.94869698136278246D-02)*T +1.54261999158247445D-01)*T + * +1.75618463128730757D-01)*T -5.05223670654169859D-01)*T + * -1.49695902416050331D-01)*T +6.91290454439828966D-01 + SCAI = Y*EXP1Z + Y = (((((((((((((((((((((((((((-8.01144609907912212D-11*T + * +2.67566208080291037D-10)*T +1.74416971406971503D-10)*T + * -3.12642164666800066D-09)*T +1.22114569059570056D-08)*T + * -2.93647730218878800D-08)*T +1.76951994785830839D-08)*T + * +2.13143266932123830D-07)*T -1.15569603602267288D-06)*T + * +3.34394065752949896D-06)*T -5.20143492253259528D-06)*T + * -3.21937890029830155D-06)*T +5.00360593064643409D-05)*T + * -1.77449408434194908D-04)*T +3.86357389967150628D-04)*T + * -4.53337922165622921D-04)*T -2.60866378774883161D-04)*T + * +3.01355585350049504D-03)*T -8.39047077309199055D-03)*T + * +1.63240267627966090D-02)*T -1.90830727084112485D-02)*T + * +1.65592661387959142D-02)*T +1.76101803014184860D-02)*T + * -3.36652019472526494D-02)*T +1.23831258886916327D-01)*T + * -6.48342330363017516D-02)*T +2.20310550882807725D-01)*T + * -1.03883014957365224D-02)*T +2.06857611342460346D-01 + SCBI = Y/EXP2Z + 30 Y = ((((((((((((((((((((((( -2.31635825886515692D-11*T + * +8.43840142802870600D-11)*T +3.68028065271203758D-10)*T + * -2.61043232825754937D-09)*T -4.65110871930215858D-10)*T + * +4.46164842334855713D-08)*T -9.24599436690579710D-08)*T + * -4.55809882095931368D-07)*T +2.21024501804834447D-06)*T + * +1.50251398952558802D-06)*T -2.91830008657289876D-05)*T + * +3.51391100964982453D-05)*T +2.37966767002002741D-04)*T + * -7.00969870295148024D-04)*T -9.84923358717942729D-04)*T + * +6.68935321740601810D-03)*T -1.66398286740112083D-03)*T + * -3.83618654865390504D-02)*T +4.80463615092658847D-02)*T + * +1.28359791076466449D-01)*T -2.80267155846714091D-01)*T + * -2.06049815358004057D-01)*T +7.63522843530878467D-01)*T + * +6.47699892977822355D-02)*T -8.32940737409625965D-01 + SCAIP = Y*EXP2Z + Y = (((((((((((((((((((((((((((+2.69330665471830131D-10*T + * -1.25313111217921013D-09)*T +1.45057587508619405D-09)*T + * +5.82827351134571594D-09)*T -3.96093412314305685D-08)*T + * +1.37346521367521144D-07)*T -2.78927594518121271D-07)*T + * +2.96531845420687661D-08)*T +2.27734981888044076D-06)*T + * -1.02295902888535994D-05)*T +2.65515218319523965D-05)*T + * -3.86457370206378782D-05)*T -1.52212232476268640D-05)*T + * +2.84765225803690646D-04)*T -9.65798046252914453D-04)*T + * +2.04618065580453522D-03)*T -2.68702422147972510D-03)*T + * +8.36839039610090712D-04)*T +6.87131161447866570D-03)*T + * -2.10563741100004648D-02)*T +4.13290131622517073D-02)*T + * -5.03310394511775398D-02)*T +5.95467795825179773D-02)*T + * -1.64213101223235839D-02)*T +5.02536006477020710D-02)*T + * +5.75601787687195966D-02)*T +1.33220031651076020D-01)*T + * +7.76356357899154668D-02)*T +2.11213324176049168D-01 + SCBIP = Y/EXP1Z + RETURN + 40 IF (Z.LT.(-5.0D0)) GO TO 60 + T = Z/5.0D0 + T = -T*T*T + T = 2.0D0*T - 1.0D0 + T2 = 2.0D0*T + IF (Z.GT.(-XEPS)) GO TO 50 + A = +1.63586492025000000D-18 + B = T2*A -1.14937368283025000D-16 + C = T2*B-A +7.06090635856696000D-15 + A = T2*C-B -3.75504581033290114D-13 + B = T2*A-C +1.70874975807662448D-11 + C = T2*B-A -6.56273599013291800D-10 + A = T2*C-B +2.09250023300659871D-08 + B = T2*A-C -5.42780372893997236D-07 + C = T2*B-A +1.11655763472468469D-05 + A = T2*C-B -1.76193215080912647D-04 + B = T2*A-C +2.03792657403144947D-03 + C = T2*B-A -1.61616260941907957D-02 + A = T2*C-B +7.87369695059018748D-02 + B = T2*A-C -1.88090320218915726D-01 + C = T2*B-A +8.83593328666433903D-02 + A = T2*C-B +9.46330439565858235D-02 + F = T*A-C +7.60869994141726643D-02 + A = +1.23340698467000000D-19 + B = T2*A -9.05440546731800000D-18 + C = T2*B-A +5.83052348377146000D-16 + A = T2*C-B -3.26253073273305810D-14 + B = T2*A-C +1.56911825099665634D-12 + C = T2*B-A -6.40386375393414830D-11 + A = T2*C-B +2.18414557202733054D-09 + B = T2*A-C -6.11127835033401880D-08 + C = T2*B-A +1.37095478225289560D-06 + A = T2*C-B -2.39464595313812449D-05 + B = T2*A-C +3.13306256975299299D-04 + C = T2*B-A -2.90953380590207648D-03 + A = T2*C-B +1.76972907074092250D-02 + B = T2*A-C -6.17055677164122241D-02 + C = T2*B-A +9.52472833367213949D-02 + A = T2*C-B -4.32381694223484894D-02 + G = T*A-C +3.76828717701544063D-02 + SCAI = F - G*Z + SCBI = RT3*(F + G*Z) + 50 A = -2.51308436743000000D-18 + B = T2*A +1.65543326242034000D-16 + C = T2*B-A -9.49237123028142500D-15 + A = T2*C-B +4.68795260455788096D-13 + B = T2*A-C -1.96942895842729954D-11 + C = T2*B-A +6.93493715818491929D-10 + A = T2*C-B -2.01076965264476206D-08 + B = T2*A-C +4.69655735896232104D-07 + C = T2*B-A -8.59527033121202608D-06 + A = T2*C-B +1.18871496270269531D-04 + B = T2*A-C -1.18244097697332692D-03 + C = T2*B-A +7.87645202148185146D-03 + A = T2*C-B -3.14174372672396468D-02 + B = T2*A-C +6.20464642445295805D-02 + C = T2*B-A -4.83824291776351778D-02 + F = T*C-B +2.64808460123486707D-02 + A = +5.89382778069400000D-18 + B = T2*A -4.04811810887971000D-16 + C = T2*B-A +2.42680453287673090D-14 + A = T2*C-B -1.25683910148099294D-12 + B = T2*A-C +5.55607745069567295D-11 + C = T2*B-A -2.06683376304577072D-09 + A = T2*C-B +6.35924425685425485D-08 + B = T2*A-C -1.58422527393619013D-06 + C = T2*B-A +3.11007119112993551D-05 + A = T2*C-B -4.64189437787271433D-04 + B = T2*A-C +5.00970025411579034D-03 + C = T2*B-A -3.62166342717373453D-02 + A = T2*C-B +1.53114671641953510D-01 + B = T2*A-C -2.69270807740667256D-01 + C = T2*B-A -9.61843661149152853D-02 + A = T2*C-B +2.07099372879297732D-01 + G = T*A-C +9.79943887874547828D-02 + SCAIP = Z*Z*F - G + SCBIP = RT3*(Z*Z*F + G) + RETURN + 60 ROOTZ = SQRT(-Z) + ROOT4Z = -SQRT(ROOTZ) + ZETA = 2.0D0*(-Z)*ROOTZ/3.0D0 + T = -250.0D0/(Z*Z*Z) - 1.0D0 + A = ((((((((((((( -4.50071772808806400D-15*T + * +1.11777933477806080D-14)*T -1.39959545848483840D-14)*T + * +4.93110187870320640D-14)*T -2.02193307034590720D-13)*T + * +7.53585452663569920D-13)*T -3.14632365928501299D-12)*T + * +1.52351450024952975D-11)*T -8.75801572233507014D-11)*T + * +6.27349413509555121D-10)*T -6.02183526555303242D-09)*T + * +8.70043536788235270D-08)*T -2.32935044050984079D-06)*T + * +1.83605337367638430D-04)*T -5.64003555099413391D-01 + SCBI = A/ROOT4Z + B = (((((((((((((((( -4.12972759036723200D-15*T + * +8.36512465551360000D-15)*T -2.05945081774080000D-16)*T + * +6.23733840790323200D-15)*T -5.81333983959859200D-14)*T + * +1.52893566095288320D-13)*T -4.11064788026333184D-13)*T + * +1.33820884559538637D-12)*T -4.74293914921785574D-12)*T + * +1.84868021228605050D-11)*T -8.15686769476673166D-11)*T + * +4.19373390376196942D-10)*T -2.61584084406303574D-09)*T + * +2.10021454539364698D-08)*T -2.37847770210509358D-07)*T + * +4.43114636962516363D-06)*T -1.83241371436579068D-04)*T + * +3.89918976811026487D-02 + SCAI = (B/ZETA)/ROOT4Z + A = ((((((((((((( -4.58484390222233600D-15*T + * +1.13969221615738880D-14)*T -1.43160328250060800D-14)*T + * +5.04734978526300160D-14)*T -2.07055957015081472D-13)*T + * +7.73043520694004480D-13)*T -3.23454581960357018D-12)*T + * +1.57043540332660220D-11)*T -9.06023827679991573D-11)*T + * +6.52303613917050367D-10)*T -6.30993998756281944D-09)*T + * +9.23711460831703303D-08)*T -2.54030284953639173D-06)*T + * +2.17448385781448409D-04)*T +5.64409671680379110D-01 + SCAIP = A*ROOT4Z + B = (((((((((((((((( +4.19612197958451200D-15*T + * -8.50454708509081600D-15)*T +2.31421341122560000D-16)*T + * -6.39683104557465600D-15)*T +5.92509321833062400D-14)*T + * -1.56008660983891968D-13)*T +4.20106807813331968D-13)*T + * -1.36926896339755520D-12)*T +4.86000800286762854D-12)*T + * -1.89780061819570625D-11)*T +8.39314701970122041D-11)*T + * -4.32843814802265754D-10)*T +2.71124934991469715D-09)*T + * -2.19026888712002973D-08)*T +2.50504395196083566D-07)*T + * -4.75245434337472120D-06)*T +2.05252791097940732D-04)*T + * -5.46414841607309762D-02 + SCBIP = (B/ZETA)*ROOT4Z + ZETA = ZETA + PIB4 + RETURN + END + SUBROUTINE SET4(NLEV,JLEV,ATAU,EFACT,IUNIT) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C THIS ROUTINE SETS UP BASIS FOR ITYPE=4. +C LINEAR RIGID ROTOR + ASYMMETRIC RIGID ROTOR SCATTERING. +C INITIAL ROUTINE WRITTEN BY T.R. PHILLIPS, GISS, AUGUST 1990 +C DERIVED FROM ROUTINES SET6 AND SET3. +C EXTENSIVELY REVISED FOR MOLSCAT VERSION 12 BY TRP (JUL 93) +C CURRENT CODE ENTIRELY REWRITTEN (VERSION 14) BY S GREEN (5 AUG 94) +C +C IMPLEMENTS THREE METHODS TO INPUT BASIS: +C 1) A,B,C .GT. 0 SPECIFIED; GENERATE ASYM TOP FNS VIA SET6C ROUTINE +C 2) NLEVEL.GT.0 SPECIFIED; READ ASYM TOP FNS FROM IUNIT=IASYMU +C -- FOR BOTH 1 & 2, EXPAND WITH J2=J2MIN,J2MAX,J2STEP; LINEAR +C ROTOR ENERGIES MUST BE CALCULABLE FROM BE(2); SCREEN ON EMAX +C 3) NLEVEL.LT.0 SPECIFIED; READ ASYM TOP FNS FROM IUNIT=IASYMU +C FILTERING ON JLEVEL(3*I-1),JLEVEL(3*I)=J1,ITAU; J2=JLEVEL(3*I); +C LEVEL ENERGIES MAY BE SPECIFIED IN ELEVEL, OTHERWISE CALC'D +C + DIMENSION JLEV(2),ATAU(2) +C N.B. JLEV AND ATAU OCCUPY SAME STORAGE PASSED FROM DRIVER/BASIN +C ON ENTRY X(IXNEXT) SHOULD BE SAME AS ATAU(1)==JLEV(1) +C NOTE: NIPR NOT USED FOR JLEV STORAGE; THIS IS CONSERVATIVE +C IXNEXT MUST BE INCREMENTED TO REFLECT *ATAU* STORAGE USED. +C + LOGICAL EIN +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C +C CMBASE MADE COMPATIBLE WITH VERSION 14 (SG 2 AUG 94) + DIMENSION BE(2),ALPHAE(2),DE(2) + EQUIVALENCE (BE(1),AAE(1)), (ALPHAE(1),BBE(1)), (DE(1),CCE(1)) + COMMON /CMBASE/ AAE(2),BBE(2),CCE(2),ROTI(6),ELEVEL(1000),EMAX, + 1 WT(2),SPNUC,NLEVEL,JLEVEL(4000),JMIN,JMAX,JSTEP,ISYM(10), + 2 J2MIN,J2MAX,J2STEP,ISYM2(10),JHALF,IDENT,MXJL,MXEL +C +C DEFAULT UNIT IS STANDARD INPUT + DATA IDU/5/ +C +C CHECK FOR CORRECT IV() FLAG IN INITIALIZATION ENTRY + IF (IVLFL.NE.0) THEN + WRITE(6,690) IVLFL + 690 FORMAT(/' SET4 (JUL 93). ILLEGAL IVLFL =',I6) + STOP + ENDIF +C + IF (AAE(1).GT.0.D0.AND.BBE(1).GT.0.D0.AND.CCE(1).GT.0.D0) + 1 GO TO 3000 +C +C ASYMMETRIC TOP FUNCTIONS WILL BE INPUT FROM IUNIT; CHECK IT + WRITE(6,602) IUNIT + 602 FORMAT(/' ASYMMETRIC TOP BASIS WILL BE INPUT FROM UNIT IASYMU =', + 1 I4) + IF (NLEVEL.GT.0) THEN + NREAD=NLEVEL + WRITE(6,603) NLEVEL + 603 FORMAT(' NUMBER OF INPUT LEVELS SPECIFIED BY NLEVEL IS',I6) + ELSE + IF (IUNIT.EQ.IDU) THEN + WRITE(6,*) ' *** SET4. CANNOT READ FROM STD INPUT FOR', + 1 ' NLEVEL.LE.0' + STOP + ENDIF + NREAD=1000000 + WRITE(6,*) ' WILL INPUT LEVELS UNTIL END-OF-FILE' + ENDIF +C + IF (NLEVEL.LT.0) GO TO 7000 +C +C BELOW IS 'CASE 2' -- RESULT SHOULD BE SAME AS FOR 'CASE 1' +C +C --- READ IN ASYMMETRIC RIGID ROTOR WAVEFUNCTIONS AND ENERGIES --- +C CODE BELOW FOLLOWS SET6 CODE + NLEV=0 + IOFF=0 + NKVAL=0 + DO 2000 III=1,NREAD + READ(IUNIT,500,END=9000) JI,ITAU,EINP + 500 FORMAT(2I5,F15.10) + NLEV=NLEV+1 + JI=IABS(JI) + NK=2*JI+1 + ELEVEL(NLEV)=EINP*EFACT +C SEE IF WE SHOULD SKIP ON JMIN,JMAX,JSTEP OR EMAX + IF (JMAX.LE.0) GO TO 2080 + JDIF=JI-JMIN + JDIF=JDIF-JSTEP*(JDIF/JSTEP) + IF (JDIF.EQ.0 .AND. JI.GE.JMIN .AND. JI.LE.JMAX) GO TO 2080 + WRITE(6,611) JI,ITAU,ELEVEL(NLEV),JMIN,JSTEP,JMAX + 611 FORMAT(/' INPUT LEVEL J, TAU, E =',2I5,F13.3,' SKIPPED. ', + 1 'J NOT IN RANGE',I4,' (',I4,')',I4) + GO TO 2070 + 2080 IF (EMAX.LE.0.D0) GO TO 2090 + IF (ELEVEL(NLEV).LE.EMAX) GO TO 2090 + WRITE(6,612) JI,ITAU,ELEVEL(NLEV),EMAX + 612 FORMAT(/' INPUT LEVEL J, TAU, E =',2I5,F13.3,' SKIPPED ', + 1 'DUE TO EMAX =',F11.3) +C REACH BELOW IF WE ARE SKIPPING THIS SET + 2070 NLEV=NLEV-1 + READ(IUNIT,501,END=9100) (ATAUX,I=1,NK) + GO TO 2000 +C REACH BELOW IF WE ARE INCLUDING THIS SET + 2090 CONTINUE +C SHIFT ATAU BY 6 WORDS TO MAKE ROOM FOR NEW JLEV; NB. NIPR NOT USED + IOFF=IOFF+6 + DO 2020 I=1,NKVAL + 2020 ATAU(IOFF+NKVAL+1-I)=ATAU(IOFF+NKVAL-5-I) + INST=IOFF+NKVAL + READ(IUNIT,501,END=9100) (ATAU(INST+I),I=1,NK) + 501 FORMAT(6F12.8) +C OUTPUT INFORMATION READ. + WRITE(6,614) NLEV,JI,ITAU,EINP,ELEVEL(NLEV) + 614 FORMAT(/' INPUT LEVEL',I4,' J, TAU =',2I4,' ENERGY =',F15.5, + & ' = ',F15.5,' (1/CM)') + MJI=-JI + WRITE(6,615) (ATAU(INST+1+JI+I),I, I=MJI,JI) + 615 FORMAT(10X,'INPUT COEFFICIENTS ARE'/(10X,6(F12.6,'(',I3,')'))) +C GET PARITY CODE FROM ATAU SYMMETRIES. . . + IPAR=IPASYM(JI,NK,ATAU(INST+1)) +C IPAR=-1 IS ERROR RETURN FROM IPASYM. + IF (IPAR.NE.-1) GO TO 2001 + WRITE(6,*) ' *** SET4. TERMINAL ERROR.' + STOP +C REORDER JLEV TO RECEIVE NEW ROW. + 2001 NRM1=NLEV-1 + IF (NRM1.LE.0) GO TO 2100 + IOLD=6*NRM1 + IX=6*NLEV + DO 2110 II=1,6 + IX=IX-1 + DO 2120 I=1,NRM1 + JLEV(IX)=JLEV(IOLD) + IX=IX-1 + 2120 IOLD=IOLD-1 + 2110 CONTINUE + 2100 JLEV(NLEV)=JI + JLEV(2*NLEV)=ITAU + JLEV(3*NLEV)=IPAR + JLEV(4*NLEV)=NKVAL + JLEV(5*NLEV)=NK + JLEV(6*NLEV)=NLEV + NKVAL=NKVAL+NK + GO TO 2000 +C +C * * * END OF FILE CONDITIONS * * * + 9000 IF (NLEVEL.GT.0) GO TO 2200 + WRITE(6,606) IUNIT,NLEV + 606 FORMAT('0 END OF FILE ENCOUNTERED ON UNIT',I4,' AFTER',I5, + & ' FUNCTIONS.') + GO TO 2400 + 2200 WRITE(6,607) IUNIT,NLEV + 607 FORMAT('0 PREMATURE E.O.F. ON UNIT',I4,'. NLEVEL REDUCED TO',I6) + GO TO 2400 + 9100 WRITE(6,608) IUNIT,NLEV + 608 FORMAT('0 * * * ERROR. E.O.F. ON UNIT',I4,' BEFORE ATAU CARDS F + &OR NLEV =',I5) + WRITE(6,699) + 699 FORMAT('0 * * * TERMINAL ERROR.') + STOP + 2000 CONTINUE +C THIS COMPLETES READ(IASYMU) LOOP +C +C SET JLEVEL() (ITYPE=6 FORMAT); N.B. ELEVEL() ALREADY SET + 2400 DO 2401 I=1,NLEV + JLEVEL(2*I-1)=JLEV(I) + 2401 JLEVEL(2*I)=JLEV(I+NLEV) +C CORRECT JLEV(LEV,4) FOR SPACE TAKEN BY JLEV. . . + IF (IOFF.NE.6*NLEV) THEN + WRITE(6,698) IOFF, NLEV + 698 FORMAT(' *** SET4. INDEXING ERROR. IOFF,NLEV =',2I6) + STOP + ENDIF + IX=3*NLEV+1 + IXTOP=4*NLEV + DO 2410 I=IX,IXTOP + 2410 JLEV(I)=JLEV(I)+IOFF +C INCREMENT IXNEXT FOR STORAGE TAKEN BY ATAU + IXNEXT=IXNEXT+NKVAL +C CHECK THAT FUNCTIONS ARE ORTHOGONAL + CALL CHECK6(NLEV,JLEV,ATAU) + GO TO 4000 +C +C BELOW IS 'CASE 1', I.E. GENERATE BASIS VIA SET6C + 3000 CALL SET6C(JLEV,ATAU,NLEV,.FALSE.) +C N.B. SET6C INCREMENTS IXNEXT FOR ATAU STORAGE +C IF VALID IASYMU IS GIVEN, OUTPUT ROTOR WFNS + IF (IUNIT.LE.0.OR.IUNIT.GE.100.OR.IUNIT.EQ.IDU) GO TO 4000 + WRITE(6,*) ' *** SET4 WILL OUTPUT ROTOR WAVEFUNCTIONS TO UNIT', + 1 IUNIT + WRITE(6,*) ' IN FORMAT FOR FUTURE INPUT' + DO 1011 I=1,NLEV + JI=JLEV(I) + ITAU=JLEV(NLEV+I) + ISTA=JLEV(3*NLEV+I) + NK=JLEV(4*NLEV+I) + INDX=JLEV(5*NLEV+I) + WRITE(IUNIT,500,ERR=1099) JI,ITAU,ELEVEL(INDX) + 1011 WRITE(IUNIT,501,ERR=1099) (ATAU(ISTA+II),II=1,NK) + RETURN + 1099 WRITE(6,*) ' *** SET4. ERROR WRITING TO IASYMU; WFNS NOT SAVED' + RETURN +C +C CALL J6TO4 TO EXPAND 'ITYPE=6' TO 'ITYPE=4' FORMAT +C SET UP WORKING STORAGE. IXNEXT ALREADY REFLECTS ATAU STORAGE +C N.B. JLEV STORAGE DOES *NOT* REFLECT NIPR; SHOULD BE CONSERVATIVE + 4000 IOFF=6*NLEV + IXEL=IXNEXT+IOFF + IXJL=IXEL+MXEL + IXJNW=IXJL+MXJL + NAVAIL=MX-IXJNW + IF (NAVAIL.LT.8*NLEV) THEN + WRITE(6,*) ' *** SET4. INSUFFICIENT WORKING SPACE FOR J6TO4' + WRITE(6,*) ' IXNEXT,MX,NAVAIL =',IXNEXT,MX,NAVAIL + STOP + ENDIF +C J6TO4 EXPANDS ITYPE=6 DATA FORMAT WITH POSSIBLE J2 VALUES +C TO PRODUCE ITYPE=4 DATA FORMAT + CALL J6TO4(NLEV,JLEV,ATAU,X(IXJNW),NAVAIL,X(IXEL),X(IXJL)) + RETURN +C +C CODE BELOW IS 'CASE 3' NLEVEL.LT.0; FILTER IASYMU INPUT ON JLEVEL + 7000 NLEVEL=ABS(NLEVEL) + IF (NLEVEL.GT.MXEL) THEN + WRITE(6,*) ' *** SET4. REQUESTED NLEVEL.GT.MXEL' + STOP + ENDIF + WRITE(6,*) ' BASIS FUNCTIONS DETERMINED BY &BASIS JLEVEL()' + WRITE(6,*) ' NUMBER OF LEVELS (NLEVEL) =',NLEVEL + EIN=.FALSE. + DO 7001 I=1,NLEVEL + 7001 EIN=EIN.AND.ELEVEL(I).GT.0.D0 + IF (EIN) THEN + WRITE(6,*) + 1 ' ENERGIES FOR BASIS FNS TAKEN FROM &BASIN ELEVEL VALUES' + ELSE + IF (BE(2).LE.0.D0) THEN + WRITE(6,*) ' *** SET4. CANNOT OBTAIN LINEAR ROTOR', + 1 ' ENERGY FROM BE(2)' + STOP + ENDIF + WRITE(6,*) ' ASYMMETRIC TOP ENERGIES TAKEN FROM IASYMU' + WRITE(6,644) BE(2) + 644 FORMAT(/' LINEAR ROTOR ENERGY LEVELS COMPUTED FROM B(E) =', + 1 F12.8) + IF (ALPHAE(2).NE.0.D0) WRITE(6,645) ALPHAE(2) + 645 FORMAT(27X,'CORRECTED FOR ALPHA(E) = ',F12.8) + IF (DE(2).NE.0.D0) WRITE(6,646) DE(2) + 646 FORMAT(27X,'CORRECTED FOR D(E) = ',F12.8) + ENDIF +C BEGIN READ(IASYMU) LOOP + NLEV=0 + IOFF=0 + NKVAL=0 + DO 7100 III=1,NREAD + READ(IUNIT,500,END=9200) JI,ITAU,EINP + NK=2*JI+1 + EINX=EINP*EFACT + NMATCH=0 + DO 7200 IND=1,NLEVEL + IF (JLEVEL(3*IND-2).NE.JI.OR.JLEVEL(3*IND-1).NE.ITAU) GO TO 7200 +C WE'VE FOUND A MATCH ON JI, ITAU, + NMATCH=NMATCH+1 + J2=JLEVEL(3*IND) + FJ=DBLE(J2) + FJ=FJ*(FJ+1.D0) + E2=(BE(2)-ALPHAE(2)*0.5D0)*FJ - DE(2)*FJ*FJ + IF (.NOT.EIN) ELEVEL(IND)=EINX+E2 +C EXPAND JI WITH J2 TO J12 IN GENERATING NLEV,JLEV FROM THIS SET + J12MIN=ABS(JI-J2) + J12MAX=JI+J2 + DO 7400 J12=J12MIN,J12MAX + NLEV=NLEV+1 +C SHIFT ATAU BY 8 WORDS TO MAKE ROOM FOR INCOMING JLEV + IOFF=IOFF+8 + DO 7220 I=1,NKVAL + 7220 ATAU(IOFF+NKVAL+1-I)=ATAU(IOFF+NKVAL-7-I) +C READ ATAU, BUT ONLY THE FIRST TIME WE USE THIS WAVEFUNCTION + IF (NMATCH.EQ.1) THEN + INST=IOFF+NKVAL + READ(IUNIT,501,END=9300) (ATAU(INST+I),I=1,NK) +C OUTPUT INFORMATION READ. + WRITE(6,651) JI,ITAU,EINP,EINX + 651 FORMAT(/' INPUT LEVEL, J, TAU =',2I4,' ENERGY =',F12.4, + 1 ' = ',F12.4,' (1/CM)') + MJI=-JI + WRITE(6,652) (ATAU(INST+1+JI+I),I,I=MJI,JI) + 652 FORMAT(10X,'INPUT COEFFICIENTS ARE'/(10X,6(F12.6,'(',I3,')'))) +C GET PARITY CODE FROM ATAU SYMMETRIES. . . + IPAR=IPASYM(JI,NK,ATAU(INST+1)) +C IPAR=-1 IS ERROR RETURN FROM IPASYM. + IF (IPAR.EQ.-1) THEN + WRITE(6,*) ' *** SET4. ILEGAL SYMMETRY FOR INPUT WFN.' + STOP + ENDIF + ISTA=NKVAL + NKVAL=NKVAL+NK + ENDIF +C REORDER JLEV TO RECEIVE NEW ROW; ADAPTED FROM SET6 CODE. + NRM1=NLEV-1 + IF (NRM1.LE.0) GO TO 7300 + IOLD=8*NRM1 + IX=8*NLEV + DO 7310 II=1,8 + IX=IX-1 + DO 7320 I=1,NRM1 + JLEV(IX)=JLEV(IOLD) + IX=IX-1 + 7320 IOLD=IOLD-1 + 7310 CONTINUE + 7300 JLEV(NLEV)=J12 + JLEV(2*NLEV)=J2 + JLEV(3*NLEV)=JI + JLEV(4*NLEV)=ITAU + JLEV(5*NLEV)=IPAR + JLEV(6*NLEV)=ISTA + JLEV(7*NLEV)=NK + JLEV(8*NLEV)=IND + 7400 CONTINUE +C THIS ENDS J12 LOOP + 7200 CONTINUE +C THIS ENDS LOOP OVER NLEVEL, JLEVEL() SETS. +C IF WE DID NOT USE THIS FUNCTION (NMATCH.EQ.0) SKIP ATAU CARDS + IF (NMATCH.LE.0) READ(IUNIT,501,END=9300) (ATAUX,I=1,NK) + GO TO 7100 +C +C END OF FILE CONDITIONS + 9300 WRITE(6,*) ' *** SET4. EOF ON IASYMU WHILE READING ATAU DATA' + STOP + 9200 WRITE(6,*) ' *** SET4. NORMAL EOF ENCOUNTERED ON IASYMU' + GO TO 7500 +C + 7100 CONTINUE +C THIS ENDS LOOP OVER READ IASYMU +C +C CORRECT ISTA=JLEV(LEV,6) FOR SPACE TAKEN BY JLEV. . . + 7500 IF (IOFF.NE.8*NLEV) THEN + WRITE(6,698) IOFF, NLEV + STOP + ENDIF + IX=5*NLEV+1 + IXTOP=6*NLEV + DO 7505 I=IX,IXTOP + 7505 JLEV(I)=JLEV(I)+IOFF +C +C NEED TO SET JMIN,JMAX FOR USE IN SELECTING ORBITAL L IN BASE + JMIN=JLEV(1) + JMAX=JMIN + DO 7510 I=1,NLEV + JMIN=MIN(JMIN,JLEV(I)) + 7510 JMAX=MAX(JMAX,JLEV(I)) +C +C MAKE SURE THAT WE HAVE FOUND AN ASYMMETRIC ROTOR WFN FOR +C ALL NLEVEL JLEVEL() SETS. UNLIKE ITYPE=6, WE DO NOT REORDER + DO 7600 I=1,NLEVEL + DO 7601 IX=1,NLEV + IF (JLEV(7*NLEV+IX).EQ.IX) GO TO 7600 + 7601 CONTINUE + WRITE(6,660) I,JLEVEL(3*I-2),JLEVEL(3*I-1) + 660 FORMAT(/' *** SET4. DID NOT FIND BASIS FUNCTIONS FOR LEVEL',I4/ + 1 ' JI,ITAU =',2I6) + STOP + 7600 CONTINUE +C INCREMENT IXNEXT TO REFLECT ATAU STORAGE + IXNEXT=IXNEXT+NKVAL + RETURN +C + END + SUBROUTINE SET6(LEVIN,EIN,NLEV,JLEV,ATAU,EFACT,IUNIT) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C REVISED FOR VERSION 14: +C THREE POSSIBLE METHODS OF SPECIFYING ASYMMETRIC TOP LEVELS +C 1. A,B,C .GT.0 IMPLIES GENERATE VIA SET6C +C 2. NLEVEL.GE.0 IMPLIES READ FROM IASYMU (FILTER ON JMIN,JMAX, +C JSTEP,EMAX); IF (NLEVEL.EQ.0) READ TO END-OF-FILE +C 3. NLEVEL.LT.0 IMPLIES READ FROM IASYMU BUT ACCEPT ONLY THOSE +C J,ITAU CORRESPONDING TO JLEVEL(2*I-1),JLEVEL(2*I), +C I=1,ABS(NLEVEL) +C +C BELOW REPLACES GENERIC SAVE IN V11, WHICH APPEARED UNNECESSARY. + SAVE IFIRST,NOMEM,NL12,IXMX,ISTART +C +C THIS ROUTINE HANDLES INPUT, ALSO MATRIX ELEMENTS FOR ITYPE=6. +C LATTER ARE OBTAINED VIA ENTRIES ASYME, CPL6, CPL26. +C FIRST VERSION WRITTEN AT MPI, MUNCHEN, JULY 1976. +C CURRENT VERSION 11 MAR 93 SAVES COUPLING ELEMENTS IN X ARRAY +C ASYME (EFF. POTL) COULD BE CHANGED, BUT PROBABLY NO LONGER USED +C +C N.B. NKVAL HERE COULD BE OBTAINED AS NEEDED - NK=2*J+1. +C THIS CODE IS MORE FLEXIBLE AS NOT ALL NEED BE STORED BUT +C K-VALUE COULD BE OBTAINED VIA ADDITIONAL VECTOR KVAL(IST+1). +C + LOGICAL LEVIN,EIN + LOGICAL LIN + LOGICAL NOMEM,ODD + INTEGER JLEV(2) + DIMENSION ATAU(2) +C N.B. JLEV AND ATAU OCCUPY SAME STORAGE PASSED FROM DRIVER/BASIS. +C IXNEXT MUST BE INCREMENTED TO REFLECT *ATAU* STORAGE USED +C (BUT NOT JLEV, BECAUSE BASIN INCREMENTS IXNEXT BY NQN*NLEV) +C +C SPECIFICATIONS FOR ASYME, CPL6, CPL26 ENTRIES. + INTEGER J(N),L(N),LAM(2) + DIMENSION VL(2) + INTEGER PRINT + LOGICAL LFIRST +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) + COMMON /VLSAVE/ IVLU +C + COMMON /CMBASE/ AE(2),BE(2),CE(2),ROTI(6),ELEVEL(1000),EMAX, + & WT(2),SPNUC,NLEVEL,JLEVEL(4000),JMIN,JMAX,JSTEP,ISYM(10), + & J2MIN,J2MAX,J2STEP,ISYM2(10),JHALF,IDENT,MXJL,MXEL +C +C DEFAULT INPUT UNIT IS STANDARD INPUT ... + DATA IDU/5/ + DATA PI/3.14159 26535 89793 D0/ + DATA EPS/1.D-9/, Z0/0.D0/ +C +C STATEMENT FUNCTIONS + F(NN)=DBLE(NN+NN+1) + ODD(I)=I-2*(I/2).NE.0 +C +C CHECK FOR CORRECT IV() FLAG IN INITIALIZATION ENTRY + IF (IVLFL.NE.0) THEN + WRITE(6,690) IVLFL + 690 FORMAT(/' SET6 (JAN 93). ILLEGAL IVLFL =',I6) + STOP + ENDIF +C +C IF ROTATION CONSTANTS ARE INPUT, GENERATE BASIS VIA SET6C + IF (AE(1).GT.0.D0 .AND. BE(1).GT.0.D0 .AND. CE(1).GT.0.D0) THEN + CALL SET6C(JLEV,ATAU,NLEV,EIN) +C OPTION ADDED (AUG 94) TO OUTPUT ROTOR WFNS TO IASYMU + IF (IUNIT.LE.0.OR.IUNIT.GE.100.OR.IUNIT.EQ.IDU) RETURN + WRITE(6,*) ' *** SET6 WILL OUTPUT ROTOR WAVEFUNCTIONS TO UNIT', + 1 IUNIT + WRITE(6,*) ' IN FORMAT FOR FUTURE INPUT' + DO 1011 I=1,NLEV + JI=JLEV(I) + ITAU=JLEV(NLEV+I) + ISTA=JLEV(3*NLEV+I) + NK=JLEV(4*NLEV+I) + INDX=JLEV(5*NLEV+I) + WRITE(IUNIT,500,ERR=1099) JI,ITAU,ELEVEL(INDX) + 1011 WRITE(IUNIT,501,ERR=1099) (ATAU(ISTA+II),II=1,NK) + RETURN + 1099 WRITE(6,*) ' *** SET6. ERROR WRITING TO IASYMU; WFNS NOT SAVED' + RETURN + ENDIF +C +C OTHERWISE, INPUT FROM UNIT IASYMU + IF (IUNIT.GT.0 .AND. IUNIT.LT.100) GO TO 1000 + WRITE(6,601) IUNIT,IDU + 601 FORMAT(/' ILLEGAL UNIT =',I12,' SPECIFIED FOR IASYMU, ', + 1 'DEFAULTED TO ',I4) + IUNIT=IDU +C + 1000 WRITE(6,602) IUNIT + 602 FORMAT(/' ASYMMETRIC TOP BASIS WILL BE INPUT FROM UNIT IASYMU =', + 1 I4) + LIN=.FALSE. + IF (LEVIN) THEN + NREAD=NLEVEL + WRITE(6,603) NLEVEL + 603 FORMAT(' ',10X,I6,' INPUT LEVELS SPECIFIED BY NLEVEL.') + ELSE + IF (IUNIT.EQ.IDU) THEN + WRITE(6,*) ' *** SET6. CANNOT READ FROM STD INPUT FOR', + 1 ' NLEVEL.LE.0' + STOP + ENDIF + NREAD=1000000 + IF (NLEVEL.LT.0) THEN + LIN=.TRUE. + WRITE(6,613) NLEVEL + 613 FORMAT(5X,'NEGATIVE NLEVEL =',I5, + 1 ' WILL SCREEN INPUT ON &BASIS JLEVEL()') + NLEVEL=-NLEVEL + IF (EIN) THEN + WRITE(6,*) ' ENERGIES TAKEN FROM &BASIS ELEVEL' + ELSE + WRITE(6,*) ' ENERGIES TAKEN FROM IASYMU' + ENDIF + ENDIF + ENDIF +C + NLEV=0 + IOFF=0 + NKVAL=0 + DO 2000 III=1,NREAD + READ(IUNIT,500,END=9000) JI,ITAU,EINP + 500 FORMAT(2I5,F15.10) + NLEV=NLEV+1 + IF (NLEV.GT.MXEL) THEN + WRITE(6,*) ' *** SET6. DIMENSION OF ELEVEL EXCEEDED',NLEV + STOP + ENDIF + JI=IABS(JI) + NK=2*JI+1 + IF (LIN) THEN +C CODE BELOW FILTERS IASYMU INPUT ON JLEVEL + DO 2099 IND=1,NLEVEL + IF (JLEVEL(2*IND-1).NE.JI.OR.JLEVEL(2*IND).NE.ITAU) GO TO 2099 + INDX=IND + IF (.NOT.EIN) ELEVEL(INDX)=EINP*EFACT + GO TO 2090 + 2099 CONTINUE + WRITE(6,683) JI,ITAU,EINP + 683 FORMAT('0 INPUT LEVEL J, TAU, E =',2I5,F13.3,' SKIPPED.', + 1 ' NOT IN JLEVEL LIST') + GO TO 2070 + ELSE + ELEVEL(NLEV)=EINP*EFACT +C SEE IF WE SHOULD SKIP ON JMIN,JMAX,JSTEP OR EMAX + IF (JMAX.LE.0) GO TO 2080 + JDIF=JI-JMIN + JDIF=JDIF-JSTEP*(JDIF/JSTEP) + IF (JDIF.EQ.0 .AND. JI.GE.JMIN .AND. JI.LE.JMAX) GO TO 2080 + WRITE(6,681) JI,ITAU,ELEVEL(NLEV),JMIN,JSTEP,JMAX + 681 FORMAT('0 INPUT LEVEL J, TAU, E =',2I5,F13.3,' SKIPPED. ', + 1 'J NOT IN RANGE',I4,' (',I4,')',I4) + GO TO 2070 + 2080 IF (EMAX.LE.0.D0) GO TO 2090 + IF (ELEVEL(NLEV).LE.EMAX) GO TO 2090 + WRITE(6,680) JI,ITAU,ELEVEL(NLEV),EMAX + 680 FORMAT('0 INPUT LEVEL J, TAU, E =',2I5,F13.3,' SKIPPED ', + 1 'DUE TO EMAX =',F11.3) + ENDIF +C +C REACH BELOW IF WE ARE SKIPPING THIS SET + 2070 NLEV=NLEV-1 + READ( IUNIT,501,END=9100) (ATAUX,I=1,NK) + GO TO 2000 +C +C READ BELOW IF WE ARE INCLUDING THIS SET + 2090 CONTINUE +C SHIFT ATAU BY 6 WORDS TO MAKE ROOM FOR INCOMING JLEV. + IOFF=IOFF+6 + DO 2020 I=1,NKVAL + 2020 ATAU(IOFF+NKVAL+1-I)=ATAU(IOFF+NKVAL-5-I) + INST=IOFF+NKVAL + READ(IUNIT,501,END=9100) (ATAU(INST+I),I=1,NK) + 501 FORMAT(6F12.8) +C OUTPUT INFORMATION READ. + WRITE(6,604) NLEV,JI,ITAU,EINP,ELEVEL(NLEV) + 604 FORMAT('0 INPUT LEVEL',I4,' J, TAU =',2I4,' ENERGY =',F15.5, + & ' = ',F15.5,' (1/CM)') + MJI=-JI + WRITE(6,605) (ATAU(INST+1+JI+I),I, I=MJI,JI) + 605 FORMAT(10X,'INPUT COEFFICIENTS ARE'/(10X,6(F12.6,'(',I3,')'))) +C +C GET PARITY CODE FROM ATAU SYMMETRIES. . . + IPAR=IPASYM(JI,NK,ATAU(INST+1)) +C IPAR=-1 IS ERROR RETURN FROM IPASYM. + IF (IPAR.NE.-1) GO TO 2001 + WRITE(6,699) + STOP +C REORDER JLEV TO RECEIVE NEW ROW. + 2001 NRM1=NLEV-1 + IF (NRM1.LE.0) GO TO 2100 + IOLD=6*NRM1 + IX=6*NLEV + DO 2110 II=1,6 + IX=IX-1 + DO 2120 I=1,NRM1 + JLEV(IX)=JLEV(IOLD) + IX=IX-1 + 2120 IOLD=IOLD-1 + 2110 CONTINUE +C + 2100 JLEV(NLEV)=JI + JLEV(2*NLEV)=ITAU + JLEV(3*NLEV)=IPAR + JLEV(4*NLEV)=NKVAL + JLEV(5*NLEV)=NK + IF (LIN) THEN + JLEV(6*NLEV)=INDX + ELSE + JLEV(6*NLEV)=NLEV + ENDIF + NKVAL=NKVAL+NK + GO TO 2000 +C +C * * * END OF FILE CONDITIONS * * * + 9000 IF (LEVIN) GO TO 2200 + WRITE(6,606) IUNIT,NLEV + 606 FORMAT('0 END OF FILE ENCOUNTERED ON UNIT',I4,' AFTER',I5, + & ' FUNCTIONS.') + GO TO 2400 + 2200 WRITE(6,607) IUNIT,NLEV + 607 FORMAT('0 PREMATURE E.O.F. ON UNIT',I4,'. NLEVEL REDUCED TO',I6) + GO TO 2400 + 9100 WRITE(6,608) IUNIT,NLEV + 608 FORMAT('0 * * * ERROR. E.O.F. ON UNIT',I4,' BEFORE ATAU CARDS F + &OR NLEV =',I5) + WRITE(6,699) + 699 FORMAT('0 * * * TERMINAL ERROR.') + STOP + 2000 CONTINUE +C THIS COMPLETES READ(IASYMU) LOOP +C + 2400 IF (LIN) THEN +C WE FILTERED ON JLEVEL(), MAKE SURE WE HAVE THEM ALL + IF (NLEV.NE.NLEVEL) THEN + WRITE(6,*) ' ALL LEVELS SPECIFIED BY JLEVEL() WERE NOT FOUND' + WRITE(6,*) ' *** TERMINAL ERROR.' + STOP + ENDIF +C MAKE SURE EACH VALUE IS THERE AND REORDER IF NECESSARY +C SO THAT JLEV(I,6)=I (EXPECTED BY PRBR, EG) + DO 2409 I=1,NLEVEL + DO 2408 IX=1,NLEV + IF (I.NE.JLEV(5*NLEV+IX)) GO TO 2408 + IF (I.EQ.IX) GO TO 2409 + DO 2407 IC=1,6 + ITMP=JLEV((IC-1)*NLEV+I) + JLEV((IC-1)*NLEV+I)=JLEV((IC-1)*NLEV+IX) + 2407 JLEV((IC-1)*NLEV+IX)=ITMP + GO TO 2409 + 2408 CONTINUE + WRITE(6,684) I,JLEVEL(2*I-1),JLEVEL(2*I) + 684 FORMAT(' INPUT SET',I4,' J, TAU =',2I5,' NOT FOUND ON IASYMU' + 1 /' *** TERMINAL ERROR') + STOP + 2409 CONTINUE + ELSE +C SET J,TAU INTO JLEVEL; GET JMIN,JMAX (ARE THOSE NEEDED?) + NLEVEL=NLEV +C SET JLEVEL(), JMIN, AND JMAX. + JMIN=JLEV(1) + JMAX=JMIN + DO 2401 I=1,NLEV + JI=JLEV(I) + JLEVEL(2*I-1)=JI + JLEVEL(2*I)=JLEV(I+NLEV) + JMIN=MIN0(JMIN,JI) + 2401 JMAX=MAX0(JMAX,JI) + ENDIF +C CORRECT JLEV(LEV,4) FOR SPACE TAKEN BY JLEV. . . + IF (IOFF.NE.6*NLEV) THEN + WRITE(6,698) IOFF, NLEV + 698 FORMAT(' SET6. INDEXING ERROR. IOFF,NLEV =',2I6) + STOP + ENDIF + IX=3*NLEV+1 + IXTOP=4*NLEV + DO 2410 I=IX,IXTOP + 2410 JLEV(I)=JLEV(I)+IOFF +C CHECK THAT FUNCTIONS ARE ORTHOGONAL + CALL CHECK6(NLEV,JLEV,ATAU) +C CHECK THAT ENERGIES ARE NOT ALL IDENTICALLY ZERO. + DO 2500 I=1,NLEV + IF (ELEVEL(I).NE.0.D0) GO TO 2510 + 2500 CONTINUE + IF (NLEVEL.GT.1) THEN + WRITE(6,609) + 609 FORMAT(' *** WARNING. SET6. ENERGIES ARE ALL ZERO') + ENDIF + 2510 IXNEXT=IXNEXT+NKVAL + RETURN +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +C +C THESE ENTRY POINTS COMPUTE COUPLING MATRIX ELEMENTS . . . +C + ENTRY ASYME(N,J,L,MXLAM,LAM,VL,IV,JLEV,ATAU,NLEV) + ASSIGN 3003 TO IGO1 + ASSIGN 3033 TO IGO2 + GO TO 3000 +C + ENTRY CPL6(N,J,L,JTOT,MXLAM,LAM,VL,JLEV,ATAU,NLEV,PRINT,LFIRST) + IF (LFIRST) THEN + IFIRST=-1 + LFIRST=.FALSE. + NOMEM=.FALSE. + ENDIF + IF (IFIRST.GT.-1) GO TO 5500 + IF (NOMEM) GO TO 5900 + NL12=NLEV*(NLEV+1)/2 + IXMX=NL12*MXLAM + ISTART=MX+1 + NAVAIL=ISTART-IXNEXT + IF (IXMX.LE.NAVAIL) GO TO 5100 + IF (PRINT.GE.3) WRITE(6,694) IXMX,NAVAIL + 694 FORMAT(/' CPL6 (MAR 93). UNABLE TO STORE JTOT-INDEPENDENT PART' + 1 /' REQUIRED AND AVAILABLE STORAGE =',2I9) + NOMEM=.TRUE. + GO TO 5900 + 5100 IX=0 + DO 5200 LL=1,MXLAM + LM=LAM(2*LL-1) + XLM=LM + MU=LAM(2*LL) + XMU=MU + DO 5201 IC=1,NLEV + JC=JLEV(IC) + XJC=JC + ISTC=JLEV(IC+3*NLEV) + NKC=JLEV(IC+4*NLEV) + DO 5201 IR=1,IC + IX=IX+1 + JR=JLEV(IR) + XJR=JR + ISTR=JLEV(IR+3*NLEV) + NKR=JLEV(IR+4*NLEV) + XCPL=Z0 + KKC=-JC + DO 5300 KC=1,NKC +C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. + IF (ABS(ATAU(ISTC+KC)).LE.EPS) GO TO 5300 + XKC=KKC + KKR=-JR + DO 5400 KR=1,NKR +C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. + IF (ABS(ATAU(ISTR+KR)).LE.EPS) GO TO 5400 + XKR=KKR +C AF=ATAU(ISTR+KR)*ATAU(ISTC+KC)*PARITY3(KKR) + AF=ATAU(ISTR+KR)*ATAU(ISTC+KC) + IF (ODD(KKR)) AF=-AF + IF (KKR-KKC.NE.MU) GO TO 5401 + XCPL=XCPL+AF*THRJ(XJC,XJR,XLM,XKC,-XKR,XMU) + IF (MU.EQ.0) GO TO 5400 + 5401 IF (KKC-KKR.NE.MU) GO TO 5400 +C ADJUST FOR (-1)**MU IN POTENTIAL. . . +C AF=AF*PARITY3(MU) + IF (ODD(MU)) AF=-AF + XCPL=XCPL+AF*THRJ(XJC,XJR,XLM,XKC,-XKR,-XMU) + 5400 KKR=KKR+1 + 5300 KKC=KKC+1 +C NOW GET 'CONSTANT FACTORS' + XFCT=PARITY3(JC+JR)*SQRT((F(JC)*F(JR)*F(LM))/(4.D0*PI)) + 5201 X(ISTART-IX)=XCPL*XFCT + 5200 CONTINUE + IF (PRINT.GT.3) WRITE(6,695) IXMX + 695 FORMAT(/' CPL6 (MAR 93). JTOT-INDEPENDENT PARTS OF COUPLING', + 1 ' MATRIX STORED.'/ + 2 ' REQUIRED STORAGE =',I8) +C RESET MX, IFIRST TO REFLECT STORED VALUES + MX=MX-IXMX + IFIRST=0 +C +C NOW GET COUPLING MATRIX ELEMENTS FROM STORED PARTS + 5500 PJT=PARITY3(JTOT) + IF (IVLU.GT.0) REWIND IVLU + DO 5600 LL=1,MXLAM + LM=LAM(2*LL-1) + MU=LAM(2*LL) +C +C STORAGE FOR 3J AND 6J SYMBOLS +C + ITL=IXNEXT + IT6=ITL+2*LM+1 + IXNEXT=IT6+2*LM+1 + NUSED=0 + CALL CHKSTR(NUSED) +C + IX1=(LL-1)*NL12 + NNZ=0 + IF (IVLU.EQ.0) THEN + IX=LL + ELSE + IX=1 + ENDIF +C + LSAV=-1 + DO 5700 IC=1,N + LEVC=J(IC) + JC=JLEV(LEVC) + LC=L(IC) + IF (LC.NE.LSAV) THEN + CALL J3J000(DBLE(LC),DBLE(LM),IVALL,X(ITL),XLMIN) + LMIN=IABS(LC-LM) + LMAX=LC+LM + LSAV=LC + ENDIF +C + LSAV6=-1 + DO 5700 IR=1,IC + LEVR=J(IR) + JR=JLEV(LEVR) + LR=L(IR) +C + IF (LEVR.GE.LEVC) THEN + IX2=LEVR*(LEVR-1)/2+LEVC + ELSE + IX2=LEVC*(LEVC-1)/2+LEVR + ENDIF + INDX=IX1+IX2 +C + IF (X(ISTART-INDX).EQ.0.D0 + 1 .OR. LR.LT.LMIN .OR. LR.GT.LMAX + 2 .OR. ODD(LR+LMAX)) THEN + VL(IX)=0.D0 + ELSE + IF (LR.NE.LSAV6) THEN + IVAL6=MX-IT6+1 + CALL J6J(DBLE(LR),DBLE(JTOT),DBLE(LC),DBLE(JC),DBLE(LM), + 1 IVAL6,XJMIN6,X(IT6)) + JMIN6=INT(XJMIN6) + LSAV6=LR + ENDIF + IF (JR.LT.JMIN6 .OR. JR.GE.JMIN6+IVAL6) THEN + VL(IX)=0.D0 + ELSE + INDL=ITL+(LR-LMIN)/2 + IND6=IT6+JR-JMIN6 + VL(IX)=PJT*SQRT(F(LC)*F(LR))*X(ISTART-INDX)*X(INDL)*X(IND6) + ENDIF + ENDIF + IF (VL(IX).NE.0.D0) NNZ=NNZ+1 + IF (IVLU.EQ.0) THEN + IX=IX+MXLAM + ELSE + IX=IX+1 + ENDIF + 5700 CONTINUE + IF (NNZ.EQ.0) WRITE(6,697) LM,MU + IF (IVLU.GT.0) WRITE(IVLU) (VL(I),I=1,N*(N+1)/2) + IXNEXT=ITL + 5600 CONTINUE + RETURN +C +C IF WE CANNOT STORE PARTIAL COUPLING MATRIX, RECALCULATE. + 5900 ASSIGN 3001 TO IGO1 + ASSIGN 3011 TO IGO2 + GO TO 3000 +C + ENTRY CPL26(N,MXLAM,LAM,NLEV,JLEV,ATAU,J,MVAL,VL,PRINT,LFIRST) +C +C IF LFIRST IS TRUE (FIRST CALL), DO SOME INITIALIZATION + IF (LFIRST) THEN + IFIRST=-1 + LFIRST=.FALSE. + NOMEM=.FALSE. + ENDIF +C + IF (IFIRST.GT.-1) GO TO 4500 +C FIRST TIME THROUGH SET UP SOME STORAGE POINTERS + NL12=NLEV*(NLEV+1)/2 + IXMX=NL12*MXLAM + ISTART=MX+1 +C + 4500 MVABS=IABS(MVAL) +C SEE IF VALUES ARE STORED FOR THIS HIGH AN MVALUE +C IF NOT, TRY TO STORE THEM IN XCPL(). + IF (MVABS.LE.IFIRST.OR.NOMEM) GO TO 4900 + MV=IFIRST+1 +C FIRST CHECK THAT WE STILL HAVE A CONTINUOUS BLOCK OF HI MEMORY. + 4600 IF (MX.EQ.ISTART-(IFIRST+1)*IXMX-1) GO TO 4610 + IF (PRINT.GE.1) WRITE(6,642) MV,ISTART-1,MX,IXMX*(IFIRST+1) + 642 FORMAT(/' CPL26 (FEB 93). HIGH MEMORY FRAGMENTED. CANNOT', + 1 ' STORE COUPLING COEFFS FOR MVAL=',I3/ 19X, + 2 'ORIGINAL MINUS CURRENT MEMORY LIMITS .NE. NO. USED =',3I12) + NOMEM=.TRUE. + GO TO 4900 +C TEST FOR AVAILABLE STORAGE; NEED IXMX FOR THIS MVAL + 4610 NAVAIL=MX-IXNEXT+1 + IF (IXMX.LE.NAVAIL) GO TO 4601 + IF (PRINT.GE.3) WRITE(6,692) MV,IXMX,NAVAIL + 692 FORMAT(/' CPL26 (FEB 93). UNABLE TO STORE 3-J VALUES FOR MVAL=' + 1 ,I3/' REQUIRED AND AVAILABLE STORAGE =',2I9) +C SET NOMEM TO REFLECT INABILITY TO ADD MORE M-VALUES + NOMEM=.TRUE. + GO TO 4900 +C +C REDUCE 'TOP OF MEMORY' AND STORE COUPLING VALUES FOR THIS MVAL + 4601 MX=MX-IXMX +C START INDEX AFTER M-BLOCKS ALREADY STORED (STARTING WITH MV=0) + IX=MV*IXMX + DO 4200 LL=1,MXLAM + LM=LAM(2*LL-1) + MU=LAM(2*LL) + DO 4201 IC=1,NLEV + JC=JLEV(IC) + ISTC=JLEV(IC+3*NLEV) + NKC=JLEV(IC+4*NLEV) + DO 4201 IR=1,IC + JR=JLEV(IR) + ISTR=JLEV(IR+3*NLEV) + NKR=JLEV(IR+4*NLEV) + IX=IX+1 + XCPL=Z0 + KKC=-JC + DO 4300 KC=1,NKC +C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. + IF (ABS(ATAU(ISTC+KC)).LE.EPS) GO TO 4300 + KKR=-JR + DO 4400 KR=1,NKR +C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. + IF (ABS(ATAU(ISTR+KR)).LE.EPS) GO TO 4400 + AF=ATAU(ISTR+KR)*ATAU(ISTC+KC) + IF (KKR-KKC.NE.MU) GO TO 4401 + XCPL=XCPL+AF*GSYMTP(JC,KKC,JR,KKR,MV ,LM,MU) + IF (MU.EQ.0) GO TO 4400 + 4401 IF (KKC-KKR.NE.MU) GO TO 4400 +C ADJUST FOR (-1)**MU IN POTENTIAL. . . +C AF=AF*PARITY3(MU) + IF (ODD(MU)) AF=-AF + XCPL=XCPL+AF*GSYMTP(JC,KKC,JR,KKR,MV,LM,-MU) + 4400 KKR=KKR+1 + 4300 KKC=KKC+1 + 4201 X(ISTART-IX)=XCPL + 4200 CONTINUE + IF (PRINT.GT.3) WRITE(6,693) MV,IXMX,NAVAIL + 693 FORMAT(/' CPL26 (FEB 93). 3-J VALUES STORED FOR MVAL =',I3 + 1 /' REQUIRED AND AVAILABLE STORAGE =',2I9) +C RESET IFIRST TO REFLECT HIGHEST M-VALUE STORED. + IFIRST=MV +C SEE IF CURRENT MVALUE REQUIRES MORE STORED M-VALUES. + MV=MV+1 + IF (MV.LE.MVABS) GO TO 4600 +C + 4900 IF (MVABS.GT.IFIRST) GO TO 4800 +C MVABS.LE.IFIRST. COEFFS STORED. FILL VL() FROM XCPL + IXM=MVABS*IXMX + IF (IVLU.GT.0) REWIND IVLU + DO 4513 LL=1,MXLAM + LM=LAM(2*LL-1) + NNZ=0 + IF (IVLU.EQ.0) THEN + IX=LL + ELSE + IX=1 + ENDIF + DO 4503 ICOL=1,N + I1=J(ICOL) + J1=JLEV(I1) + DO 4503 IROW=1,ICOL + I2=J(IROW) + J2=JLEV(I2) + IF (I1.GT.I2) THEN + IX12=I1*(I1-1)/2+I2 + ELSE + IX12=I2*(I2-1)/2+I1 + ENDIF + IXX=IXM+(LL-1)*NL12+IX12 + VL(IX)=X(ISTART-IXX) +C WE HAVE STORED COUPLING FOR POSITIVE MVALUES; CORRECT IF NECESSARY +C FOR PARITY OF THRJ(J1,LM,J2,-MVAL,0,MVAL) + IF (MVAL.LT.0.AND.ODD(J1+J2+LM)) VL(IX)=-VL(IX) + IF (VL(IX).NE.Z0) NNZ=NNZ+1 + IF (IVLU.EQ.0) THEN + IX=IX+MXLAM + ELSE + IX=IX+1 + ENDIF + 4503 CONTINUE + IF (NNZ.LE.0 .AND. PRINT.GE.3) WRITE(6,612) MVAL,LL + 612 FORMAT(' * * * NOTE. FOR MVALUE, SYM =',2I4,', ALL COUPLING ', + & 'COEFFICIENTS ARE 0.') + IF (IVLU.GT.0) WRITE(IVLU) (VL(I),I=1,N*(N+1)/2) + 4513 CONTINUE + RETURN +C +C MV.GT.IFIRST ==> VALUES NOT STORED. CALCULATE THEM VIA OLD CODE + 4800 ASSIGN 3002 TO IGO1 + ASSIGN 3022 TO IGO2 + GO TO 3000 +C +C -------------------- OLD CODE REJOINS HERE --------------------- +C + 3000 IF (IVLU.GT.0) REWIND IVLU + DO 3100 LL=1,MXLAM + LM=LAM(2*LL-1) + MU=LAM(2*LL) + NNZ=0 + IF (IVLU.EQ.0) THEN + IX=LL + ELSE + IX=1 + ENDIF +C + DO 3200 IC=1,N + JC=JLEV(J(IC)) + ISTC=JLEV(J(IC)+3*NLEV) + NKC=JLEV(J(IC)+4*NLEV) + DO 3200 IR=1,IC + JR=JLEV(J(IR)) + ISTR=JLEV(J(IR)+3*NLEV) + NKR=JLEV(J(IR)+4*NLEV) +C + VL(IX)=0.D0 + KKC=-JC + DO 3300 KC=1,NKC +C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. + IF (ABS(ATAU(ISTC+KC)).LE.EPS) GO TO 3300 + KKR=-JR + DO 3400 KR=1,NKR +C SKIP IMMEDIATELY IF COEFFICIENT IS SMALL. + IF (ABS(ATAU(ISTR+KR)).LE.EPS) GO TO 3400 + AF=ATAU(ISTR+KR)*ATAU(ISTC+KC) + IF (KKR-KKC.NE.MU) GO TO 3500 + GO TO IGO1,(3001,3002,3003) + 3001 VL(IX)=VL(IX)+AF*FSYMTP(JC,KKC,L(IC),JR,KKR,L(IR),JTOT,LM,MU) + GO TO 3009 + 3002 VL(IX)=VL(IX)+AF*GSYMTP(JC,KKC,JR,KKR,MVAL,LM,MU) + GO TO 3009 + 3003 VL(IX)=VL(IX)+AF*ESYMTP(JC,KKC,JR,KKR,LM,MU) +C + 3009 IF (MU.EQ.0) GO TO 3400 + 3500 IF (KKC-KKR.NE.MU) GO TO 3400 +C ADJUST FOR (-1)**MU IN POTENTIAL. . . + AF=AF*PARITY3(MU) + GO TO IGO2,(3011,3022,3033) + 3011 VL(IX)=VL(IX)+AF*FSYMTP(JC,KKC,L(IC),JR,KKR,L(IR),JTOT,LM,-MU) + GO TO 3400 + 3022 VL(IX)=VL(IX)+AF*GSYMTP(JC,KKC,JR,KKR,MVAL,LM,-MU) + GO TO 3400 + 3033 VL(IX)=VL(IX)+AF*ESYMTP(JC,KKC,JR,KKR,LM,-MU) +C + 3400 KKR=KKR+1 + 3300 KKC=KKC+1 + IF (VL(IX).NE.0.D0) NNZ=NNZ+1 + IF (IVLU.EQ.0) THEN + IX=IX+MXLAM + ELSE + IX=IX+1 + ENDIF + 3200 CONTINUE + IF (NNZ.EQ.0) WRITE(6,697) LM,MU + 697 FORMAT(' * * * NOTE. ALL COUPLING COEFFICIENTS ARE ZERO FOR ', + & 'LAMBDA, MU =', 2I4) + IF (IVLU.GT.0) WRITE(IVLU) (VL(I),I=1,N*(N+1)/2) + 3100 CONTINUE + RETURN + END + SUBROUTINE SET6C(JLEV,ATAU,NLEV,EIN) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C save statement should be unnec; only called once (sg aug 94) + SAVE + LOGICAL EIN + DIMENSION JLEV(1),ATAU(1) + DIMENSION ROTI(12),WT(2),ELEVEL(1000),JLEVEL(4000) + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C MODS 11 JUL 94 FOR V14 CMBASE +C n.b IPAR was equivalenced to J2MAX, now to ISYM(1) + EQUIVALENCE (IPAR,ISYM(1)) + COMMON /CMBASE/ ROTI,ELEVEL,EMAX,WT,SPNUC, + 1 NLEVEL,JLEVEL,JMIN,JMAX,JSTEP,ISYM(10),J2MIN,J2MAX, + 2 J2STEP,ISYM2(10),JHALF,IDENT,MXJL,MXEL + DATA TOL/1.D-8/ +C +C CALCULATE ASYMMETRIC ROTOR ENERGY LEVELS AND WAVEFUNCTIONS +C FROM ROTATIONAL CONSTANTS. WRITTEN BY JMH, MARCH 1989. +C MODIFIED TO HANDLE SPHERICAL TOP SYMMETRY, APRIL 1991. +C MODIFIED TO USE WORKSPACE PROPERLY FOR VERSION 12, NOV 1993. +C + IF(EIN) WRITE(6,601) + 601 FORMAT('0 TARGET ENERGY LEVELS TAKEN FROM &BASIS (ELEVEL)'/ + 1 ' WILL OVERRIDE THOSE CALCULATED FROM ROTATIONAL CONSTANTS') + IF(ROTI(1).EQ.ROTI(3) .AND. ROTI(3).EQ.ROTI(5)) THEN + WRITE(6,602) ROTI(1),ROTI(7),ROTI(10) + 602 FORMAT('0 SPHERICAL ROTOR LEVELS CALCULATED FROM'/ + 1 ' A = B = C =',F11.5/' DJ',8X,'=',E11.3/' DT',8X,'=',E11.3) + IF(ABS(ROTI(10)).LT.1.D-8) WRITE(6,603) + 603 FORMAT(' *** WARNING: IF ABS(DT) IS LESS THAN ABOUT 1.D-8,', + 1 ' THE PROGRAM MAY FAIL TO DISTINGUISH LEVELS OF DIFFERENT', + 2 ' SYMMETRY') + ELSE + WRITE(6,604) ROTI(1),ROTI(3),ROTI(5), + 1 ROTI(7),ROTI(8),ROTI(9) + 604 FORMAT('0 ASYMMETRIC ROTOR LEVELS CALCULATED FROM'/ + 1 ' A =',F10.5,8X,'B =',F10.5,8X,'C =',F10.5/ + 2 ' DJ =',E10.3,8X,'DJK =',E10.3,8X,'DK =',E10.3/ + 3 '0 A, B AND C MUST CORRESPOND TO THE X, Y AND Z', + 4 ' COORDINATES USED TO DEFINE THE INTERACTION POTENTIAL') + ENDIF + WRITE(6,605) IPAR + 605 FORMAT('0 INPUT ENERGY LEVELS WILL BE INCLUDED ONLY IF THEY', + 1 ' MEET SELECTION CRITERIA SPECIFIED BITWISE BY ISYM =',I4) +C +C NTAU IS SAFELY ABOVE ANYTHING WE MAY NEED FOR JLEV +C + NLVL=0 + ESAVE=-999.D0 + NLEV=0 + NTAU=6*(JMAX+1)**2 + NORIG=NTAU + IXSAVE=IXNEXT + DO 450 J=JMIN,JMAX,JSTEP + NVEC=NTAU + NK=J+J+1 +C +C ASROT NEEDS SOMEWHERE TO PUT THE EIGENVALUES AND EIGENVECTORS +C AND SOME WORKSPACE. USE THE TOP OF THE ATAU ARRAY. +C + IC2=NVEC+1+NK*NK + IC3=IC2+NK*NK + IC4=IC3+NK + IXNEXT=IC4+NK + NUSED=1 + CALL CHKSTR(NUSED) + CALL ASROT(J,ATAU(NVEC+1),ATAU(IC2),ATAU(IC3),ATAU(IC4),NK) + DO 440 IK=1,NK +C +C CHECK LEVEL ENERGY AND PARITY TO SEE WHETHER WE REALLY WANT IT +C + ELEV=ATAU(IC3+IK-1) + IF(EMAX.GT.0.D0 .AND. ELEV.GT.EMAX) GOTO 430 + IPLEV=IPASYM(J,NK,ATAU(NVEC+1)) +C +C IPAR IS INTERPRETED BITWISE: THE BITS ARE FLAGS AS FOLLOWS +C 1 - ODD K EXCLUDED +C 2 - EVEN K EXCLUDED +C 3 - ODD +/-K * (-1)**J EXCLUDED +C 4 - EVEN +/-K * (-1)**J EXCLUDED +C 5 - DEGENERACY = 1 EXCLUDED +C 6 - DEGENERACY = 2 EXCLUDED +C 7 - DEGENERACY = 3 EXCLUDED +C 8 - DEGENERACY > 3 EXCLUDED +C +C NOTE THAT THIS LOGIC WAS CHANGED IN AUGUST 1992, +C IN A WAY THAT ALTERS THE INPUT VALUE OF ISYM REQUIRED, +C FOLLOWING BETA TESTING OF VERSION 11 +C + IF(IPAR.LE.0) GOTO 410 +C +C FIND DEGENERACY +C + IDEG=0 + DO 400 KK=1,NK + IF(ABS(ATAU(IC3+KK-1)-ELEV).LT.TOL) IDEG=IDEG+1 + 400 CONTINUE +C + JPAR=IPAR +C + IP=MOD(JPAR,2) + JPAR=JPAR/2 + IF(IP.EQ.1 .AND. IPLEV.GE.2) GOTO 430 +C + IP=MOD(JPAR,2) + JPAR=JPAR/2 + IF(IP.EQ.1 .AND. IPLEV.LE.1) GOTO 430 +C + IP=MOD(JPAR,2) + JPAR=JPAR/2 + IF(IP.EQ.1 .AND. MOD(IPLEV+J,2).EQ.1) GOTO 430 +C + IP=MOD(JPAR,2) + JPAR=JPAR/2 + IF(IP.EQ.1 .AND. MOD(IPLEV+J,2).EQ.0) GOTO 430 +C + IP=MOD(JPAR,2) + JPAR=JPAR/2 + IF(IP.EQ.1 .AND. IDEG.EQ.1) GOTO 430 +C + IP=MOD(JPAR,2) + JPAR=JPAR/2 + IF(IP.EQ.1 .AND. IDEG.EQ.2) GOTO 430 +C + IP=MOD(JPAR,2) + JPAR=JPAR/2 + IF(IP.EQ.1 .AND. IDEG.EQ.3) GOTO 430 +C + IP=MOD(JPAR,2) + JPAR=JPAR/2 + IF(IP.EQ.1 .AND. IDEG.GT.3) GOTO 430 +C + 410 NLEV=NLEV+1 + IF(NLEVEL.GT.0 .AND. NLEV.GT.NLEVEL) GOTO 430 +C +C ARRIVE HERE IF WE DO: STORE JLEV AND TAU IN TEMPORARY LOCATIONS +C + PREV=ESAVE + ESAVE=ELEV + IF(ABS(ESAVE-PREV).GT.TOL) THEN + NLVL=NLVL+1 + JLEVEL(2*NLVL-1)=J + JLEVEL(2*NLVL)=IK + IF(.NOT.EIN) ELEVEL(NLVL)=ELEV + ENDIF +C + JLEV(6*NLEV-5)=J + JLEV(6*NLEV-4)=IK + JLEV(6*NLEV-3)=IPLEV + JLEV(6*NLEV-2)=NTAU + JLEV(6*NLEV-1)=NK + JLEV(6*NLEV )=NLVL +C +C NTAU KEEPS TRACK OF WHERE WE ARE PUTTING THE COEFFICIENTS, +C AND NVEC KEEPS TRACK OF WHERE THEY ARE COMING FROM. +C NTAU IS NEVER LESS THAN NVEC. +C + DO 420 I=1,NK + ATAU(NTAU+I)=ATAU(NVEC+I) + 420 CONTINUE + NTAU=NTAU+NK + 430 NVEC=NVEC+NK + 440 CONTINUE + 450 CONTINUE +C +C COPY ATAU INTO THE RIGHT PLACE +C + IF(NLEVEL.GT.0) NLEV=MIN(NLEV,NLEVEL) + IF(NLEVEL.EQ.0) NLEVEL=NLVL + NBASE=6*NLEV + NSHIFT=NORIG-NBASE + DO 460 I=NORIG+1,NTAU + 460 ATAU(I-NSHIFT)=ATAU(I) + NTAU=NTAU-NSHIFT +C +C COPY JLEV INTO WORKSPACE ABOVE ATAU AND REARRANGE IT, +C REMEMBERING TO MODIFY THE POINTER TO ATAU. +C + NBASE=2*NTAU + I=0 + DO 470 NL=1,NLEV + DO 470 IQ=1,6 + I=I+1 + IF(IQ.EQ.4) JLEV(I)=JLEV(I)-NSHIFT + JLEV(NBASE+NL+NLEV*(IQ-1))=JLEV(I) + 470 CONTINUE +C +C THEN COPY IT BACK TO WHERE IT BELONGS +C + DO 480 I=1,6*NLEV + 480 JLEV(I)=JLEV(NBASE+I) + IXNEXT=IXSAVE+NTAU + RETURN + END + SUBROUTINE SET6I(JLEV,MXLV,NLEV,A,MXA,IUNIT) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION JLEV(MXLV) + DIMENSION A(MXA) + DATA IDU/5/ +C + NTOP=MXLV/4 + ISTA=0 +C ALLOW FOR EMPTY SET OF BASIS FUNCTIONS, I.E., NLEV.LE.0 + IF (NLEV.LE.0) GO TO 3000 + IF (NLEV.LE.NTOP) GO TO 1000 + WRITE(6,603) NLEV,NTOP + 603 FORMAT('0 INPUT NLEVEL =',I7, + 1 ' REPLACED BY MAX ALLOWED BY DIMENSIONS =',I5) + NLEV=NTOP +C + 1000 IF (IUNIT.GT.0) GO TO 1001 + WRITE(6,601) IUNIT,IDU + 601 FORMAT('0 ILLEGAL UNIT =',I12,' SPECIFIED FOR IASYMU, CHANGED TO' + & ,I4) + IUNIT=IDU + 1001 WRITE(6,602) IUNIT,NLEV + 602 FORMAT('0 ASYMMETRIC TOP BASIS WILL BE INPUT FROM UNIT IASYMU =', + & I4/'0 NUMBER OF REQUESTED LEVELS, NLEVEL =',I4 ) +C + NL=0 + DO 2000 III=1,NLEV + READ(IUNIT,500,END=9000) JI,ITAU,EIN + 500 FORMAT(2I5,F15.10) +C N.B. ENERGY (EIN) NOT USED FOR IOS, KEPT FOR MOLSCAT COMPATIBILITY + NL=NL+1 + JI=IABS(JI) + NK=2*JI+1 + IF (ISTA+NK.GT.MXA) GO TO 9001 + READ(IUNIT,501,END=9100) (A(ISTA+I),I=1,NK) + 501 FORMAT(6F12.8) + WRITE(6,604) NL,JI,ITAU + 604 FORMAT('0 INPUT LEVEL',I4,' J, TAU =',2I4) + MJI=-JI + WRITE(6,605) (A(ISTA+1+JI+I),I,I=MJI,JI) + 605 FORMAT(10X,'INPUT COEFFICIENTS ARE'/(10X,6(F12.6,'(',I3,')'))) + IPAR=IPASYM(JI,NK,A(ISTA+1)) + IF (IPAR.NE.-1) GO TO 2001 + WRITE(6,619) + 619 FORMAT('0 *** ILLEGAL PARITY. BASIS FUNCTION REMOVED.') + NL=NL-1 + GO TO 2000 +C ADD INDICES TO JLEV. . . + 2001 JLEV(4*NL-3)=JI + JLEV(4*NL-2)=ITAU + JLEV(4*NL-1)=IPAR + JLEV(4*NL )=ISTA + ISTA=ISTA+NK + GO TO 2000 +C END OF FILE AND OTHER ERROR CONDITIONS + 9000 WRITE(6,606) IUNIT,NL + 606 FORMAT('0 END OF FILE ON UNIT',I4,' AFTER',I4,' FUNCTIONS.') + GO TO 2400 + 9001 WRITE(6,607) MXA,NL + 607 FORMAT('0 OUT OF ROOM IN ATAU MATRIX. MXA, NLEV =',2I6) + NL=NL-1 + GO TO 2400 + 9100 WRITE(6,608) NL + 608 FORMAT('0 * * * ERROR. END OF FILE BEFORE ATAU CARDS FOR LEVEL', + & I4,'. * * * TERMINATING.') + STOP + 2000 CONTINUE +C + 2400 NLEV=NL + 3000 MXA=ISTA + CALL CHCK6I(NLEV,JLEV,A) + RETURN + END + SUBROUTINE SETBAS + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE +C + LOGICAL LEVIN,EIN + INTEGER NLEV,JLEV(1) +C +C VERSION 14 CMBASE +C COMMON BLOCK FOR BASIS DATA + DIMENSION ROTI(12),ALPHAE(2),BE(2),DE(2),WE(2),WEXE(2),A(2),B(2), + 1 C(2),WT(2),ELEVEL(1000) + DIMENSION JLEVEL(4000),ISYM(10),ISYM2(10) + EQUIVALENCE (ROTI(1),BE(1),A(1)), (ROTI(3),ALPHAE(1),B(1)), + 1 (ROTI(5),DE(1),C(1)),(JMIN,J1MIN),(JMAX,J1MAX),(JSTEP,J1STEP), + 2 (ROTI(7),WE(1)), (ROTI(9),WEXE(1)),(KMAX,J2MAX) + COMMON /CMBASE/ ROTI,ELEVEL,EMAX,WT,SPNUC,NLEVEL,JLEVEL, + 1 JMIN,JMAX,JSTEP,ISYM,J2MIN,J2MAX,J2STEP,ISYM2,JHALF,IDENT +C +C + ENTRY SET1(LEVIN,EIN,NLEV,JLEV) + IF (LEVIN) GO TO 1902 + WRITE(6,601) JMIN,JMAX,JSTEP + 601 FORMAT(/' TARGET ROTATIONAL LEVELS COMPUTED FROM JMIN =',I3, + 1 ', JMAX =',I3,', AND JSTEP =',I2) + JMIN=MAX0(0,JMIN) + JMAX=MAX0(JMIN,JMAX) + NLEVEL=0 + DO 1012 I=JMIN,JMAX,JSTEP + NLEVEL=NLEVEL+1 + 1012 JLEVEL(NLEVEL)=I + GO TO 1802 + 1902 WRITE(6,632) NLEVEL + 632 FORMAT(/' TARGET ROTATIONAL LEVELS TAKEN FROM &BASIS (JLEVEL) ', + 1 'INPUT. NLEVEL =',I3) + 1802 JMIN=JLEVEL(1) + JMAX=JMIN + NLEV=NLEVEL + DO 1912 I=1,NLEVEL + JI=JLEVEL(I) + IF (JI.LT.JMIN) JMIN=JI + IF (JI.GT.JMAX) JMAX=JI + JLEV(NLEV+I)=I + 1912 JLEV(I)=JI + IF (EIN) GO TO 7002 + WRITE(6,633) BE(1) + 633 FORMAT(/' ENERGY LEVELS COMPUTED FROM B(E) =',F12.6) + IF (ALPHAE(1).NE.0.D0) WRITE(6,634) ALPHAE(1) + 634 FORMAT(' WITH B(V) COMPUTED FROM B(E) AND ALPHA(E) =',F10.6) + IF (DE(1).NE.0.D0) WRITE(6,635) DE(1) + 635 FORMAT(' ROTATIONAL ENERGIES CORRECTED FOR D(E) =',F12.8) + DO 1702 I=1,NLEV + JI=JLEV(I) + FJ=JI*(JI+1) + 1702 ELEVEL(I)=(BE(1)-ALPHAE(1)/2.D0)*FJ - DE(1)*FJ*FJ + RETURN + 7002 WRITE(6,631) + 631 FORMAT(/' TARGET ENERGY LEVELS TAKEN FROM &BASIS (ELEVEL) INPUT') + RETURN +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +C + ENTRY SET2(LEVIN,EIN,NLEV,JLEV) + IF (LEVIN) GO TO 2902 + WRITE(6,201) + 201 FORMAT(/' * * * ERROR. FOR ITYPE=2 &BASIS MUST SPECIFY NLEVEL ', + 1 'AND J, V PAIRS') + STOP + 2902 WRITE(6,632) NLEVEL + JMIN=JLEVEL(1) + JMAX=JMIN + NLEV=NLEVEL + DO 2912 I=1,NLEVEL + JI=JLEVEL(2*I-1) + JVI=JLEVEL(2*I) + JMIN=MIN0(JMIN,JI) + JMAX=MAX0(JMAX,JI) + JLEV(2*NLEV+I)=I + JLEV(NLEV+I)=JVI + 2912 JLEV(I)=JI + IF(EIN) GO TO 2002 + WRITE(6,202) WE(1),BE(1) + 202 FORMAT(/' ENERGY LEVELS COMPUTED FROM W(E) =',F10.4, + 1 ', B(E) =',F10.4/9X,'WITH ZERO ENERGY AT V=0, J=0') + IF (WEXE(1).NE.0.D0) WRITE(6,636) WEXE(1) + 636 FORMAT(' CORRECTED FOR W(E)X(E) =',F10.4) + IF (ALPHAE(1).NE.0.D0) WRITE(6,634) ALPHAE(1) + IF (DE(1).NE.0.D0) WRITE(6,635) DE(1) + DO 2702 I=1,NLEV + JI=JLEV(I) + JVI=JLEV(NLEV+I) + FJ=JI*(JI+1) + FV=JVI + 2702 ELEVEL(I)=WE(1)*FV-WEXE(1)*FV*(FV+1.D0)+(BE(1)-ALPHAE(1) + 1 *(FV+0.5D0))*FJ - DE(1)*FJ*FJ + RETURN + 2002 WRITE(6,631) + RETURN +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +C + ENTRY SET3(LEVIN,EIN,NLEV,JLEV) + IF (IDENT.EQ.0) GO TO 1993 + J2MIN=J1MIN + J2MAX=J1MAX + J2STEP=J1STEP + IF (BE(2).EQ.0.D0) BE(2)=BE(1) + IF (ALPHAE(2).EQ.0.D0) ALPHAE(2)=ALPHAE(1) + IF (DE(2).EQ.0.D0) DE(2)=DE(1) + 1993 IF (LEVIN) GO TO 5303 + WRITE(6,310) J1MIN,J1MAX,J1STEP,J2MIN,J2MAX,J2STEP + 310 FORMAT(/' TARGET ROTOR LEVELS COMPUTED FROM J1MIN =',I3, + 1 ', J1MAX =',I3,', J1STEP =',I2// + 2 ' PROJECTILE ROTOR LEVELS COMPUTED FROM J2MIN =',I3, + 3 ', J2MAX =',I3,', J2STEP =',I2) + J1MIN=MAX0(J1MIN,0) + J1MAX=MAX0(J1MIN,J1MAX) + J1STEP=MAX0(J1STEP,1) + J2MIN=MAX0(J2MIN,0) + J2MAX=MAX0(J2MAX,J2MIN) + J2STEP=MAX0(J2STEP,1) + NLEVEL=0 + I=1 + DO 1013 JJ1=J1MIN,J1MAX,J1STEP + DO 1013 JJ2=J2MIN,J2MAX,J2STEP + IF (IDENT.NE.0 .AND. JJ1.GT.JJ2) GO TO 1013 + JLEVEL(I)=JJ1 + JLEVEL(I+1)=JJ2 + I=I+2 + NLEVEL=NLEVEL+1 + 1013 CONTINUE + GO TO 1023 + 5303 WRITE(6,333) NLEVEL + 333 FORMAT(/' TARGET/PROJECTILE ENERGY LEVELS TAKEN FROM &BASIS ', + 1 '(JLEVEL) INPUT. NLEVEL =',I3) +C PROCESS JLEVEL TO JLEV FORMAT. JMIN(JMAX) ARE LOW(HIGH) OF J12. + 1023 JMIN=IABS(JLEVEL(1)-JLEVEL(2)) + JMAX=JMIN +C EXPAND J1, J2 TO J1, J2, J12 + NLEV=0 + DO 1033 I=1,NLEVEL + JJ1=JLEVEL(2*I-1) + JJ2=JLEVEL(2*I) + JK=IABS(JJ1-JJ2) + JTOP=JJ1+JJ2 + DO 1033 J12=JK,JTOP + JLEV(4*NLEV+1)=JJ1 + JLEV(4*NLEV+2)=JJ2 + JLEV(4*NLEV+3)=J12 + JLEV(4*NLEV+4)=I + NLEV=NLEV+1 + JMIN=MIN0(JMIN,J12) + JMAX=MAX0(JMAX,J12) + 1033 CONTINUE +C REARRANGE TO PROPER ORDER IN HIGHER JLEV STORAGE + JK=4*NLEV + DO 1043 I=1,NLEV + JLEV(JK+I)=JLEV(4*I-3) + JLEV(JK+NLEV+I)=JLEV(4*I-2) + JLEV(JK+2*NLEV+I)=JLEV(4*I-1) + 1043 JLEV(JK+3*NLEV+I)=JLEV(4*I) +C COPY BACK . . . + DO 1053 I=1,JK + 1053 JLEV(I)=JLEV(JK+I) +C SET ELEVEL VALUES + IF (EIN) GO TO 1073 + WRITE(6,633) BE(1) + IF (ALPHAE(1).NE.0.D0) WRITE(6,634) ALPHAE(1) + IF (DE(1).NE.0.D0) WRITE(6,635) DE(1) + WRITE(6,313) BE(2) + 313 FORMAT(/' PROJECTILE ENERGY LEVELS COMPUTED FROM B(E) =',F12.6) + IF (ALPHAE(2).NE.0.D0) WRITE(6,634) ALPHAE(2) + IF (DE(2).NE.0.D0) WRITE(6,635) DE(2) + DO 1063 I=1,NLEVEL + FJ=DBLE(JLEVEL(2*I-1)) + GJ=DBLE(JLEVEL(2*I)) + FJ=FJ*(FJ+1.D0) + GJ=GJ*(GJ+1.D0) + 1063 ELEVEL(I)=(BE(1)-ALPHAE(1)*0.5D0)*FJ - DE(1)*FJ*FJ + 1 + (BE(2)-ALPHAE(2)*0.5D0)*GJ - DE(2)*GJ*GJ + RETURN + 1073 WRITE(6,312) + 312 FORMAT(/' TARGET/PROJECTILE ENERGY LEVELS TAKEN FROM &BASIS ', + 1 '(ELEVEL) INPUT') + RETURN +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * +C + ENTRY SET5(LEVIN,EIN,NLEV,JLEV) +C +C N.B. WE USE D(L,K,M) WITH EDMONDS CONVENTIONS OF PHASE FOR THE +C BASIS FUNCTIONS. THIS IS SAME AS THADDEUS IN H2CO PAPER. +C + IF (LEVIN) GO TO 5305 + NLEVEL=0 + I=0 + WRITE(6,601) JMIN,JMAX,JSTEP + IF(KMAX.LT.0) WRITE(6,602) -KMAX + 602 FORMAT(10X,' ABS(K) FOR ALL LEVELS SET TO',I4) + IF(KMAX.GE.0 .AND. KMAX.LT.JMAX) WRITE(6,603) KMAX + 603 FORMAT(10X,' ONLY LEVELS WITH K <=',I3,' INCLUDED IN BASIS') + JMIN=MAX0(JMIN,0) + JMAX=MAX0(JMIN,JMAX) + DO 5315 JJ=JMIN,JMAX + DO 5315 KK=0,JJ + IF (KMAX.LT.0 .AND. KK+KMAX.NE.0) GO TO 5315 + IF (KMAX.GE.0 .AND. KK.GT.KMAX) GO TO 5315 + IF (MOD(JJ+KK,JSTEP).NE.JMIN) GO TO 5314 + JLEVEL(I+1)=JJ + JLEVEL(I+2)=KK + JLEVEL(I+3)=2 + I=I+3 + NLEVEL=NLEVEL+1 + 5314 IF(KK.EQ.0) GOTO 5315 + IF (MOD(JJ+KK+1,JSTEP).NE.JMIN) GO TO 5315 + JLEVEL(I+1)=JJ + JLEVEL(I+2)=KK + JLEVEL(I+3)=1 + I=I+3 + NLEVEL=NLEVEL+1 + 5315 CONTINUE + GO TO 5355 + 5305 WRITE(6,632) NLEVEL + 5355 JMIN=JLEVEL(1) + JMAX=JMIN + NLEV=NLEVEL + DO 5325 I=1,NLEVEL + JLEV(I)=JLEVEL(3*I-2) + JLEV(NLEV+I)=JLEVEL(3*I-1) + JLEV(2*NLEV+I)=JLEVEL(3*I) + JLEV(3*NLEV+I)=I + JJ=JLEV(I) + IF (JJ.LT.JMIN) JMIN=JJ + IF (JJ.GT.JMAX) JMAX=JJ + 5325 CONTINUE + IF (EIN) GO TO 5335 + WRITE(6,604) A(1),B(1),C(1) + 604 FORMAT(/' ENERGY LEVELS COMPUTED FROM ZEROTH ORDER ', + 1 'NEAR-SYMMETRIC TOP FORMULA'/ + 2 10X,'ROTATIONAL CONSTANTS ARE A, B, C (1/CM) =',3F12.4/ + 3 10X,'N.B. THESE MOMENTS MUST CORRESPOND RESPECTIVELY TO ', + 4 'X, Y, Z COORDINATES USED TO DEFINE INTERACTION POTENTIAL') + DO 5345 I=1,NLEV + JJ=JLEV(I) + KK=IABS(JLEV(I+NLEV)) + SS=(-1.D0)**JLEV(I+2*NLEV) + HKK=(A(1)+B(1))*DBLE(JJ*(JJ+1)-KK*KK)/2.D0+ C(1)*DBLE(KK*KK) +C OFF-DIAGONAL CONTRIBUTION ONLY FROM K=1/K=-1 CASE. . . + IF (KK.EQ.1) HKK=HKK+ SS * (A(1)-B(1)) * + 1 SQRT(DBLE((JJ*(JJ+1)-KK*(KK-1))*(JJ*(JJ+1)-(KK-1)*(KK-2))))/4.D0 + 5345 ELEVEL(I)=HKK + RETURN + 5335 WRITE(6,631) + RETURN +C * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * + END + SUBROUTINE SGNCHK(A,B,N) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION A(1),B(1) + IND=-N + DO 1 I=1,N + IND=IND+N + VMAX=0.D0 + JMAX=0 + DO 2 J=1,N + IF(ABS(B(IND+J)).LT.VMAX) GO TO 2 + JMAX=J + VMAX=B(IND+JMAX) +2 CONTINUE + IF(JMAX.EQ.0) GO TO 999 + TEST=SIGN(B(IND+JMAX),A(IND+JMAX)) + IF(TEST.EQ.B(IND+JMAX)) GO TO 1 + DO 3 J=1,N + B(IND+J)=-B(IND+J) +3 CONTINUE +1 CONTINUE + RETURN +999 WRITE(6,100) +100 FORMAT(/10X,'JMAX EQ. 0 IN SGNCHK') + RETURN + END + SUBROUTINE SHRINK(ICODE,RNOW,W,N,VL,IV,NB,J,L,EINT,CENT,WVEC, + 1 CLOSE,VECOLD,EIGOLD,R,T,DEEP,NSQ,NPOTL,ISCRU,NOPMAX,PRINT) +C +C SUBROUTINE TO PERFORM A CHANNELECTOMY. +C SHRINK REMOVES THE HIGHEST-ENERGY CHANNEL(S) FROM THE PRIMITIVE +C BASIS SET, AND MODIFIES NUMEROUS ARRAYS TO REFLECT THIS. +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + INTEGER PRINT + DIMENSION W(1),VL(1),IV(1),NB(N),J(N),L(N),EINT(N),CENT(N), + 1 WVEC(N),CLOSE(N),VECOLD(NSQ),EIGOLD(N),R(1),T(1) +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C + IF(ISCRU.LE.0) GOTO 100 + IF(ICODE.EQ.1) WRITE(ISCRU) VECOLD + IF(ICODE.EQ.2) READ(ISCRU) VECOLD + 100 CALL TRNSP(VECOLD,N) + CALL TRNSFM(VECOLD,R,T,N,.FALSE.,.TRUE.) +C + DEEP2=DEEP + DO 1000 NNEW=N,1,-1 + IF(NNEW.LE.NOPMAX .OR. CLOSE(NNEW).LT.DEEP2) GOTO 1100 + ISKIP=NB(NNEW) +C + I=0 + INEW=0 + DO 200 II=1,NNEW + DO 200 JJ=1,NNEW + I=I+1 + IF(II.EQ.ISKIP .OR. JJ.EQ.ISKIP) GOTO 200 + INEW=INEW+1 + W(INEW)=W(I) + R(INEW)=R(I) + 200 CONTINUE +C + INEW=0 + DO 300 I=1,NNEW + IF(I.EQ.ISKIP) GOTO 300 + INEW=INEW+1 + J(INEW)=J(I) + L(INEW)=L(I) + EINT(INEW)=EINT(I) + CENT(INEW)=CENT(I) + WVEC(INEW)=WVEC(I) + 300 CONTINUE +C + I=0 + INEW=0 + DO 400 II=1,NNEW + DO 400 JJ=1,II + DO 400 K=1,NPOTL + I=I+1 + IF(II.EQ.ISKIP .OR. JJ.EQ.ISKIP) GOTO 400 + INEW=INEW+1 + VL(INEW)=VL(I) + IF (IVLFL.NE.0) IV(INEW)=IV(I) + 400 CONTINUE +C + DO 500 I=1,NNEW + 500 IF(NB(I).GE.ISKIP) NB(I)=NB(I)-1 +C + 1000 CONTINUE +C + 1100 N=NNEW + IF (ICODE.EQ.2) GOTO 1300 + IF(PRINT.GE.8) WRITE(6,601) N,RNOW + 601 FORMAT(' BASIS SET CONTRACTED TO N =',I3,' AT R =',F6.2,' A') + IFAIL=0 + CALL F02ABF(W,N,N,EIGOLD,VECOLD,N,T,IFAIL) + IF(ISCRU.GT.0) WRITE(ISCRU) VECOLD + GOTO 1400 +C + 1300 IF(ISCRU.GT.0) READ(ISCRU) VECOLD + 1400 CALL TRNSFM(VECOLD,R,T,N,.FALSE.,.TRUE.) + NSQ=N*N +C + RETURN + END + SUBROUTINE SIG6(NLEV,JLEV,A,LI,LF,SIG,S,IMSG,QL,IXQL,NIXQL,NQL, + 1 LM,LMAX) +C ROUTINE TO EVALUATE SIG(J,TAU->J',TAU') FROM IOS Q(L,M1,M2) +C VALUE FOR LEVEL LI TO LF RETURNED IN SIG +C SG(2/1/93) VERSION TAKES STORAGE FOR REAL/IMAGINARY COEFFS +C FROM /MEMORY/ ..,X + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION JLEV(4,NLEV),A(2),IXQL(NIXQL,NQL),LM(3,LMAX) + DIMENSION QL(2) + CHARACTER*1 S,STAR +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C + DATA STAR/'*'/ + DATA EPS/1.D-8/ +C +C STATEMENT FUNCTION FOR INDEX M1.GE.M2, M STARTING AT ZERO. + IX(M1,M2)=M1*(M1+1)/2+M2+1 +C + SIG=0.D0 + JI=JLEV(1,LI) + XJI=JI + NKI=2*JI+1 + ISTAI=JLEV(4,LI) + JF=JLEV(1,LF) + XJF=JF + NKF=2*JF+1 + ISTAF=JLEV(4,LF) + LMN=IABS(JI-JF) + LMX=JI+JF + DO 1100 L=LMN,LMX + XL=L +C DETERMINE AMOUNT OF AVAILABLE SCRATCH STORAGE IN X(). + MAXC=MX-IXNEXT+1 +C M-VALUES CAN RANGE UP TO L. CHECK ABILITY TO STORE IN CR,CI + MMAX=L + 1101 IXMX=IX(MMAX,MMAX) + IF (2*IXMX.LE.MAXC) GO TO 1102 + WRITE(6,699) L,IXMX,MAXC + 699 FORMAT(' *** CANNOT STORE ALL CR,CI FOR L=',I3, + 1 '. REQUIRED, AVAILABLE =',2I7) + MMAX=MMAX-1 + S=STAR + IMSG=1 + IF (MMAX.LT.0) THEN + WRITE(6,698) LI,LF + 698 FORMAT(/' SIG6 (2/1/93). FOR INITIAL FINAL LEVELS',2I3, + 1 ' AVAILABLE STORAGE IS INADEQUATE') + STOP + ENDIF + GO TO 1101 +C SET STORAGE POINTERS AND ZERO TEMP STORAGE. + 1102 IXSAVE=IXNEXT + IXR=IXNEXT-1 + IXI=IXR+IXMX + IXNEXT=IXI+IXMX + DO 1109 II=1,IXMX + X(IXR+II)=0.D0 + 1109 X(IXI+II)=0.D0 +C -------------LOOP OVER IPI,IPF IQI,IQF ----------- + IPI=-JI-1 + DO 1201 IIPI=1,NKI + IPI=IPI+1 + API=A(ISTAI+IIPI) + IF (ABS(API).LE.EPS) GO TO 1201 + PI=IPI + IPF=-JF-1 + DO 1200 IIPF=1,NKF + IPF=IPF+1 + APF=A(ISTAF+IIPF) + IF (ABS(APF).LE.EPS) GO TO 1200 + PF=IPF + IF (IABS(IPI-IPF).GT.MMAX) GO TO 1200 + IQI=-JI-1 + DO 1301 IIQI=1,NKI + IQI=IQI+1 + AQI=A(ISTAI+IIQI) + IF (ABS(AQI).LE.EPS) GO TO 1301 + QI=IQI + IQF=-JF-1 + DO 1300 IIQF=1,NKF + IQF=IQF+1 + AQF=A(ISTAF+IIQF) + IF (ABS(AQF).LE.EPS) GO TO 1300 + QF=IQF + IF (IABS(IQI-IQF).GT.MMAX) GO TO 1300 +C CALCULATE FACTOR + TJ1 = THRJ(XJI,XL,XJF,-PI,PI-PF,PF) + IF (ABS(TJ1).LE.EPS) GO TO 1300 + TJ2 = THRJ(XJI,XL,XJF,-QI,QI-QF,QF) + IF (ABS(TJ2).LE.EPS) GO TO 1300 + FACT=API*AQI*APF*AQF *TJ1*TJ2 +C RECALCULATE MP,MQ AS THEY MIGHT HAVE BEEN SWAPPED IN LAST LOOP. + MP=IPI-IPF + MQ=IQI-IQF + SIGNR=1.D0 + SIGNI=1.D0 + IF (MP.GE.0) GO TO 1401 + P=PARITY3(MP) + SIGNR=P*SIGNR + SIGNI=P*SIGNI + MP=IABS(MP) + 1401 IF (MQ.GE.0) GO TO 1402 + P=PARITY3(MQ) + SIGNR=P*SIGNR + SIGNI=P*SIGNI + MQ=IABS(MQ) + 1402 IF (MP.GE.MQ) GO TO 1403 + SIGNI=-SIGNI + MT=MP + MP=MQ + MQ=MT + 1403 INDX=IX(MP,MQ) + IF (MP.EQ.MQ) SIGNI=0.D0 + X(IXR+INDX)=X(IXR+INDX)+SIGNR*FACT + X(IXI+INDX)=X(IXI+INDX)+SIGNI*FACT +C**** WRITE(6,686) INDX,X(IXR+INDX),X(IXI+INDX) **** DEBUGGING **** + 686 FORMAT(' INDX, REAL/IMAG =',I5,2F10.5) + 1300 CONTINUE + 1301 CONTINUE +C ---------- THIS ENDS LOOP OVER IQI,IQF + 1200 CONTINUE + 1201 CONTINUE +C ---------- THIS ENDS LOOP OVER IPI,IPF +C MATCH CONTRIBUTING (I.E., NON-ZERO) CR WITH QL VALUES + IZERO=0 + INDX=0 + DO 1500 MP=IZERO,MMAX + DO 1500 MQ=IZERO,MP + INDX=INDX+1 +C N.B. IMAGINARY PART SHOULD VANISH; ERROR MESSAGE IF ANY SURVIVE. + IF (ABS(X(IXI+INDX)).LE.EPS) GO TO 1501 + WRITE(6,694) L,MP,MQ,X(IXI+INDX),LI,LF + 694 FORMAT('0 *** ERROR. NON-ZERO IMAGINARY COEFF QL(', + & 3I4,' ) =',F12.6,' FOR LI,LF =',2I4) + 1501 IF (ABS(X(IXR+INDX)).LE.EPS) GO TO 1500 +C CALL IXQLF TO GET INDEX OF L,MP,MQ IN QL +C AND ACCUMULATE IN CROSS SECTION + CALL IXQLF(LM,LMAX,L,MP,MQ,1,INDEX,IXQL,NIXQL,NQL) +C N.B. 6TH ARG (1) ASKS FOR REAL PART; SHOULD WORK OK FOR MP.EQ.MQ + IF (INDEX.GT.0) GO TO 1502 + IF (INDEX.EQ.-1) GO TO 1500 + S=STAR + IMSG=1 + GO TO 1500 + 1502 SIG=SIG + X(IXR+INDX)*QL(INDEX) +C WRITE(6,602) LI,LF,L,MP,MQ,X(IXR+INDX),QL(INDEX) *** DEBUGGING** + 602 FORMAT(2X,'I/F=',2I3,' QL(',3I3,' ) COEFF/QL =',2F10.5) + 1500 CONTINUE +C RECOVER TEMPORARY STORAGE ... + 1100 IXNEXT=IXSAVE +C ---------- THIS ENDS LOOP OVER L - VALUES +C MULTIPLY FINALLY BY 2*JF+1 + SIG = SIG * (2*JF+1) + RETURN + END + FUNCTION SIXJ(J1,J2,J5,J4,J3,J6) +C +C CALCULATES 6-J SYMBOL: _(J1 J2 J3 )_ +C (J4 J5 J6 ) +C INTERFACE TO J6J ROUTINE. +C MODIFIED BY S. GREEN 20 AUG 93; PASS DIMENSION OF XJ6J FOR CHECKING +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + PARAMETER(MXDIM=200) + DIMENSION XJ6J(MXDIM) + IVAL=MXDIM + CALL J6J( DBLE(J2),DBLE(J3), + 1 DBLE(J4),DBLE(J5),DBLE(J6), + 3 IVAL,XJ1MIN,XJ6J) + IND=1+J1-INT(XJ1MIN+0.1D0) + SIXJ=0.D0 + IF(IND.GE.1 .AND. IND.LE.IVAL) SIXJ=XJ6J(IND) + RETURN + END +* ---------------------------------------------------------------------- + SUBROUTINE SPROPN (WIDTH, EIGNOW, HP, Y1, Y4, Y2, NCH) +* CURRENT REVISION DATE: 23-9-87 +*----------------------------------------------------------------------- +* THIS SUBROUTINE CALCULATES THE DIAGONAL MATRICES TO PROPAGATE THE +* LOG-DERIVATIVE MATRIX THROUGH THE CURRENT INTERVAL +* THE KEY EQUATIONS, REPRODUCED BELOW, ARE TAKEN FROM +* M. ALEXANDER AND D. MANOLOPOULOS, "A STABLE LINEAR REFERENCE POTENTIA +* ALGORITHM FOR SOLUTION ..." +* EACH UNCOUPLED EQUATION CAN BE WRITTEN AS: +* 2 2 +* [ D / DR + EIGNOW - HP * R ] F(R) = 0 +* WHERE R IS THE DISTANCE FROM THE MIDPOINT OF THE CURRENT INTERVAL +* THE LINEARLY INDEPEDENT SOLUTIONS ARE THE AIRY FUNCTIONS AI(X) AND BI +* WHERE X = ALPHA (R + BETA) +* 1/3 +* WITH ALPHA = HP , AND BETA = (-EIGNOW) / HP +* THE THREE DIAGONAL ELEMENTS OF THE CAUCHY PROPAGATOR NECESSARY TO PRO +* THE LOG-DERIVATIVE MATRIX ARE: +* B = PI [ AI(X ) BI(X ) - AI(X )BI(X ) ] / ALPHA +* 1 2 2 1 +* A = PI [ - AI'(X ) BI(X ) + AI(X ) BI'(X ) ] +* 1 2 2 1 +* D = PI [ AI(X ) BI'(X ) - AI'(X ) BI(X ) ] +* 1 2 2 1 +* WHERE X = ALPHA ( BETA + WIDTH / 2) AND +* 2 +* X = ALPHA ( BETA - WIDTH / 2) +* 1 +* HERE "WIDTH" DENOTES THE WIDTH OF THE INTERVAL +* THE DIAGONAL ELEMENTS OF THE "IMBEDDING TYPE" PROPAGATOR ARE GIVEN IN +* OF THE DIAGONAL ELEMENTS OF THE CAUCHY PROPAGATOR BY: +* Y = A/B Y = Y = 1/B AND Y = D/B +* 1 2 3 4 +*----------------------------------------------------------------------- +* VARIABLES IN CALL LIST: +* WIDTH: WIDTH OF THE CURRENT INTERVAL +* EIGNOW: ARRAY CONTAINING THE WAVEVECTORS +* THESE ARE DEFINED BY EQ. (6) OF M.ALEXANDER, +* J. CHEM. PHYS. 81,4510 (1984) +* HP: ARRAY CONTAINING THE NEGATIVE OF DIAGONAL ELEMENTS OF T +* DERIVATIVE OF THE WAVEVECTOR MATRIX AT THE CENTER OF TH +* CURRENT INTERVAL [SEE EQ. (9) OF M.ALEXANDER, +* J. CHEM. PHYS. 81,4510 (1984) +* THIS ARRAY THUS CONTAINS THE DERIVATIVE OF THE DIAGONAL +* ELEMENTS OF THE TRANSFORMED HAMILTONIAN MATRIX +* Y1, Y2, Y4: ON RETURN, CONTAIN THE DESIRED DIAGONAL ELEMENTS OF THE +* IMBEDDING PROPAGATOR +* NCH: THE NUMBER OF CHANNELS, THIS EQUALS THE DIMENSIONS OF T +* EIGNOW, HP, Y1, Y4, AND B ARRAYS +*----------------------------------------------------------------------- +* THE AIRY FUNCTIONS ARE DEFINED IN TERMS OF THEIR MODULI AND PHASES +* FOR NEGATIVE X THESE DEFINITIONS ARE: +* AI(-X) = M(X) COS[THETA(X)] +* BI(-X) = M(X) SIN[THETA(X)] +* AI'(-X) = N(X) COS[PHI(X)] +* BI'(-X) = N(X) SIN[PHI(X)] +* IN OTHER WORDS +* 2 2 2 +* M(X) = SQRT[ AI(X) + BI(X) ] +* 2 2 2 +* N(X) = SQRT[ AI'(X) + BI'(X) ] +* THETA(X) = ATAN [ BI(X) / AI(X) ] +* PHI(X) = ATAN [ BI'(X) / AI'(X) ] +* FOR POSITIVE X THE MODULI AND PHASES ARE DEFINED BY: +* AI(X) = M(X) SINH[THETA(X)] +* BI(X) = M(X) COSH[THETA(X)] +* AI'(X) = N(X) SINH[PHI(X)] +* BI'(X) = N(X) COSH[PHI(X)] +* IN OTHER WORDS +* 2 2 2 +* M(X) = SQRT[ BI(X) - AI(X) ] +* 2 2 2 +* N(X) = SQRT[ BI'(X) - AI'(X) ] +* THETA(X) = ATANH [ AI(X) / BI(X) ] +* PHI(X) = ATANH [ AI'(X) / BI'(X) ] +* HERE THE THE EXPONENTIALLY SCALED AIRY FUNCTIONS +* AI(X), AI'(X), BI(X), BI'(X) ARE: +* AI(X) = AI(X) * EXP[ZETA] +* AI'(X) = AI'(X) * EXP[ZETA] +* BI(X) = BI(X) * EXP[-ZETA] +* BI'(X) = BI'(X) * EXP[-ZETA] +* 3/2 +* WHERE ZETA = (2/3) X +* NOTE THAT FOR POSITIVE X THE PHASES ARE LABELED CHI AND ETA IN +* M. ALEXANDER AND D. MANOLOPOULOS, "A STABLE LINEAR REFERENCE POTENTIA +* ALGORITHM FOR SOLUTION ..." +*----------------------------------------------------------------------- +* FOR BOTH X AND X NEGATIVE +* 1 2 +* (THIS CORRESPONDS TO A CHANNEL WHICH IS CLASSICALLY OPEN AT BOTH ENDS +* INTERVAL) +* WE FIND: +* Y = 1 / { M M SIN[THETA -THETA ] } +* 2 1 2 2 1 +* N SIN[PHI -THETA ] +* 1 1 2 +* Y = ---------------------- +* 1 M SIN[THETA - THETA ] +* 1 2 1 +* N SIN[PHI -THETA ] +* 2 2 1 +* Y = ---------------------- +* 4 M SIN[THETA - THETA ] +* 2 2 1 +* HERE THE SUBSCRIPTS 1 AND 2 IMPLY THE MODULI AND PHASES EVALUATED AT +* +* AND X = X , RESPECTIVELY +* 2 +*----------------------------------------------------------------------- +* FOR BOTH X AND X POSITIVE +* 1 2 +* (THIS CORRESPONDS TO A CHANNEL WHICH IS CLASSICALLY CLOSED AT BOTH EN +* THE INTERVAL) +* WE FIND: +* 1 / Y = M M COSH[Z -Z ] { SINH[THETA -THETA ] +* 2 1 2 2 1 1 2 +* + TANH[Z -Z ] SINH[THETA +THETA ] } +* 2 1 1 2 +* 3/2 +* WHERE Z = (2/3) X AND SIMILARLY FOR Z +* 1 1 2 +* N { SINH [THETA -PHI ] - TANH[Z -Z ] SINH[THETA +PHI ] } +* 1 2 1 2 1 2 1 +* Y = -------------------------------------------------------- +* 1 M { SINH [THETA -THETA ] + TANH[Z -Z ] SINH[THETA +THETA ] } +* 1 2 1 2 1 2 1 +* N { SINH [THETA -PHI ] - TANH[Z -Z ] SINH[THETA +PHI ] } +* 2 1 2 2 1 1 2 +* Y = -------------------------------------------------------- +* 4 M { SINH [THETA -THETA ] + TANH[Z -Z ] SINH[THETA +THETA ] } +* 2 2 1 2 1 2 1 +*----------------------------------------------------------------------- +* FOR X POSITIVE AND X NEGATIVE WE FIND: +* 1 2 +* 1 / Y = M M COSH[Z ] COSH[THETA ] { - COS[THETA ] (1 + TANH[Z ]) +* 2 1 2 1 1 2 1 +* + TANH[THETA ] SIN[THETA ] (1 - TANH +* 1 2 +* N { COS[THETA ](1 + TANH[Z ]) - TANH[PHI ] SIN[THETA ] (1 - TANH[ +* 1 2 1 1 2 +* Y = ------------------------------------------------------------------ +* 1 M {-COS[THETA ](1 + TANH[Z ]) + TANH[THETA ] SIN[THETA ] (1 - TAN +* 1 2 1 1 2 +* N {-COS[PHI ](1 + TANH[Z ]) + TANH[THETA ] SIN[PHI ] (1 - TANH[Z +* 2 2 1 1 2 1 +* Y = ----------------------------------------------------------------- +* 4 M {-COS[THETA ](1 + TANH[Z ]) + TANH[THETA ] SIN[THETA ] (1 - TAN +* 2 2 1 1 2 +*----------------------------------------------------------------------- +* FOR X NEGATIVE AND X POSITIVE WE FIND: +* 1 2 +* 1 / Y = M M COSH[Z ] COSH[THETA ] { COS[THETA ] (1 + TANH[Z ]) +* 2 1 2 2 2 1 2 +* - TANH[THETA ] SIN[THETA ] (1 - TANH[ +* 2 1 +* N {-COS[PHI ](1 + TANH[Z ]) + TANH[THETA ] SIN[PHI ] (1 - TANH[Z +* 1 1 2 2 1 2 +* Y = ----------------------------------------------------------------- +* 1 M {COS[THETA ](1 + TANH[Z ]) - TANH[THETA ] SIN[THETA ] (1 - TANH +* 1 1 2 2 1 +* N { COS[THETA ](1 + TANH[Z ]) - TANH[PHI ] SIN[THETA ] (1 - TANH[ +* 2 1 2 2 1 +* Y = ----------------------------------------------------------------- +* 4 M {COS[THETA ](1 + TANH[Z ]) - TANH[THETA ] SIN[THETA ] (1 - TANH +* 2 1 2 2 1 +*----------------------------------------------------------------------- +* FOR THE SPECIAL CASE OF A CONSTANT REFERENCE POTENTIAL (HP=0) +* THEN THE PROPAGATORS ARE: +* FOR EIGNOW .GT. 0 (THE CLASSICALLY ALLOWED REGION) +* Y1 = Y4 = K COT (K WIDTH) +* Y2 = K / SIN (K WIDTH) +* WHERE K = SQRT (EIGNOW) +* FOR EIGNOW .LT. 0 (THE CLASSICALLY FORBIDDEN REGION) +* Y1 = Y4 = KAP COTH (KAP WIDTH) +* Y2 = KAP / SINH (KAP WIDTH) +* +* WHERE KAP = SQRT (-EIGNOW) +*----------------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DOUBLE PRECISION DALPHA, DBETA, DHALF, DONETH, DROOT, DSLOPE, + : DTWOTH, DLZETA, DMMOD1, DMMOD2, DNMOD1, DNMOD2, + : DPI, DX1, DX2, DZETA1, DZETA2, DPHI1, DPHI2, + : DTHET1, DTHET2, DTNHFM, DTNHFP, DARG, DCAY, DKAP, + : OFLOW,X1,X2 +* REAL B, BFACT, TNHFAC, WIDTH +* REAL EIGNOW(1), HP(1), Y1(1), Y2(1), Y4(1) + DIMENSION EIGNOW(1), HP(1), Y1(1), Y2(1), Y4(1) + INTEGER I, NCH + DATA DONETH, DTWOTH, DHALF + : / 0.333333333333333D0, 0.666666666666667D0, 0.5D0 / + DATA DPI / 3.1415926535897932D0 / +* THE PARAMETER OFLOW IS THE LARGEST VALUE OF X FOR WHICH EXP(X) +* DOES NOT CAUSE A SINGLE PRECISION OVERFLOW +* N +* A REASONABLE VALUE IS X = [ LN(2) 2 ] - 5, WHERE N IS THE NUMBER OF B +* THE CHARACTERISTIC OF A FLOATING POINT NUMBER + DATA OFLOW / 83.D0 / +* NOW DETERMINE B_MIN1, Y1, AND Y4 PARAMETERS FOR ALL NCH CHANNELS + DO 10 I = 1, NCH + DSLOPE = HP(I) + DARG = 1.E+10 + IF (DSLOPE .NE. 0.D0) + : DARG = LOG (ABS(EIGNOW(I))) - LOG (ABS(DSLOPE)) + IF (DARG .GT. 20.D0 ) THEN +* HERE IF THE RELATIVE SLOPE IN THE WAVEVECTOR MATRIX IS LESS THAN 1.** +* IN MAGNITUDE, IN WHICH CASE THE POTENTIAL IS ASSUMED TO BE CONSTANT + IF (EIGNOW(I) .GT. 0) THEN +* HERE FOR CLASSICALLY ALLOWED REGION (SINES AND COSINES AS REFERENCE +* SOLUTIONS) + DCAY = SQRT (EIGNOW(I)) + DARG = DCAY * WIDTH + Y1(I) = DCAY / TAN (DARG) + Y4(I) = Y1(I) + Y2(I) = DCAY / SIN (DARG) + ELSE +* HERE FOR CLASSICALLY FORBIDDEN REGION (HYPERBOLIC SINES AND COSINES A +* REFERENCE SOLUTIONS) + DKAP = SQRT ( - EIGNOW(I)) + DARG = DKAP * WIDTH + Y1(I) = DKAP / TANH (DARG) + Y4(I) = Y1(I) + Y2(I) = DKAP / SINH (DARG) + END IF + ELSE +* HERE IF THE RELATIVE SLOPE IN THE WAVEVECTOR MATRIX IS GREATER THAN +* 1.**(-20) IN MAGNITUDE, IN WHICH CASE A LINEAR REFERENCE POTENTIAL IS +* WITH AIRY FUNCTIONS AS REFERENCE SOLUTIONS + DROOT = ( ABS (DSLOPE) ) ** DONETH + DALPHA = SIGN (DROOT, DSLOPE) + DBETA = - EIGNOW(I) / DSLOPE + DX1 = DALPHA * ( DBETA - WIDTH * DHALF) + DX2 = DALPHA * ( DBETA + WIDTH * DHALF) + IF (DX1 .GT. 0.) DZETA1 = DTWOTH * DX1 * SQRT(DX1) + IF (DX2 .GT. 0.) DZETA2 = DTWOTH * DX2 * SQRT(DX2) + CALL AIRYMP (DX1, DTHET1, DPHI1, DMMOD1, DNMOD1) + CALL AIRYMP (DX2, DTHET2, DPHI2, DMMOD2, DNMOD2) + X1 = DX1 + X2 = DX2 +*----------------------------------------------------------------------- + IF (X1 .GT. 0. .AND. X2 .GT. 0.) THEN +* HERE FOR BOTH X AND X POSITIVE +* 1 2 + TNHFAC = TANH(DZETA2 - DZETA1) + BFACT = SINH(DTHET1 - DTHET2) + + : TNHFAC * SINH(DTHET1 + DTHET2) + DLZETA = ABS(DZETA2 - DZETA1) + Y2(I) = 0. + IF (DLZETA .LE. OFLOW) THEN + B = DMMOD1 * DMMOD2 * COSH(DZETA2 - DZETA1) * BFACT + Y2(I) = 1. / B + END IF + Y1(I) = DNMOD1 * (SINH(DTHET2 - DPHI1) + : - TNHFAC * SINH(DTHET2 + DPHI1) ) / (DMMOD1 * BFACT) + Y4(I) = DNMOD2 * (SINH(DTHET1 - DPHI2) + : + TNHFAC * SINH(DTHET1 + DPHI2) ) / (DMMOD2 * BFACT) +*----------------------------------------------------------------------- + ELSE IF (X1 .LE. 0. .AND. X2 .LE. 0.) THEN +* HERE FOR BOTH X AND X NEGATIVE +* 1 2 + B = DMMOD1 * DMMOD2 * SIN(DTHET2 - DTHET1) + Y2(I) = 1. / B + Y1(I) = DNMOD1 * SIN(DPHI1 - DTHET2) + : / (DMMOD1 * SIN(DTHET2 - DTHET1) ) + Y4(I) = DNMOD2 * SIN(DPHI2 - DTHET1) + : / (DMMOD2 * SIN(DTHET2 - DTHET1) ) +*----------------------------------------------------------------------- + ELSE IF (X1 .GT. 0. .AND. X2 .LE. 0.) THEN +* HERE FOR X POSITIVE AND X NEGATIVE +* 1 2 + DTNHFP = 1 + TANH(DZETA1) + DTNHFM = 1 - TANH(DZETA1) + BFACT = COSH(DTHET1) * ( - COS(DTHET2) * DTNHFP + : + TANH(DTHET1) * SIN(DTHET2) * DTNHFM) + Y2(I) = 0. + IF (ABS(DZETA1) .LE. OFLOW) THEN + Y2(I) = COSH(DZETA1) * (DMMOD1 * DMMOD2 * BFACT) + Y2(I) = 1. / Y2(I) + END IF + Y1(I) = (DNMOD1 * COSH(DPHI1) * ( COS(DTHET2) * DTNHFP + : - TANH(DPHI1) * SIN(DTHET2) * DTNHFM) ) + : / (DMMOD1 * BFACT) + Y4(I) = (DNMOD2 * COSH(DTHET1) * ( - COS(DPHI2) * DTNHFP + : + TANH(DTHET1) * SIN(DPHI2) * DTNHFM) ) + : / (DMMOD2 * BFACT) +*----------------------------------------------------------------------- + ELSE IF (X2 .GT. 0. .AND. X1 .LE. 0.) THEN +* HERE FOR X POSITIVE AND X NEGATIVE +* 2 1 + DTNHFP = 1 + TANH(DZETA2) + DTNHFM = 1 - TANH(DZETA2) + BFACT = COSH(DTHET2) * ( COS(DTHET1) * DTNHFP + : - TANH(DTHET2) * SIN(DTHET1) * DTNHFM) + Y2(I) = 0. + IF (ABS(DZETA2) .LE. OFLOW) THEN + Y2(I) = COSH(DZETA2) * (DMMOD1 * DMMOD2 * BFACT) + Y2(I) = 1. / Y2(I) + END IF + Y4(I) = (DNMOD2 * COSH(DPHI2) * ( COS(DTHET1) * DTNHFP + : - TANH(DPHI2) * SIN(DTHET1) * DTNHFM) ) + : / (DMMOD2 * BFACT) + Y1(I) = (DNMOD1 * COSH(DTHET2) * ( - COS(DPHI1) * DTNHFP + : + TANH(DTHET2) * SIN(DPHI1) * DTNHFM) ) + : / (DMMOD1 * BFACT) +*----------------------------------------------------------------------- + END IF + Y1(I) = DALPHA * Y1(I) + Y4(I) = DALPHA * Y4(I) + Y2(I) = DALPHA * Y2(I) / DPI +* AT THIS POINT THE Y1, Y2, AND Y4 PROPAGATORS CORRESPOND IDENTICALLY T +* EQS. (38)-(44) OF M. ALEXANDER AND D. MANOLOPOULOS, "A STABLE LINEAR +* REFERENCE POTENTIAL ALGORITHM FOR SOLUTION ..." + END IF +10 CONTINUE + RETURN + END + SUBROUTINE STABIL(N,NB,Y,YP,F1,F2,SCR,YN,YPN,F1N,F2N) +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C FIND SCR SUCH THAT Y*SCR IS (PERMUTED) UNIT MATRIX, +C THEN TRANSFORM Y, YP, F1, AND F2 BY RIGHT MULTIPLICATION WITH SCR. +C + DIMENSION NB(N),Y(1),YP(1),F1(1),F2(1), + & YN(1),YPN(1),F1N(1),F2N(1),SCR(1) +C +C SAVE OLD INPUT MATRICES AND INITIALIZE SCR +C + NSQ=N*N + CALL DCOPY(NSQ,Y,1,YN,1) + CALL DCOPY(NSQ,YP,1,YPN,1) + CALL DCOPY(NSQ,F1,1,F1N,1) + CALL DCOPY(NSQ,F2,1,F2N,1) + DO 1100 IJ=1,NSQ + Y(IJ)=0.D0 + 1100 SCR(IJ)=0.D0 + DO 1200 I=1,N + IJ=N*(I-1)+NB(I) + Y(IJ)=1.D0 + 1200 SCR(IJ)=1.D0 +C + CALL DGESV(N,N,YN,N,YP,SCR,N,IER) + IF (IER.EQ.0) GO TO 2000 + WRITE(6,600) + 600 FORMAT(' * * * WARNING - STABILIZATION WITH BAD MATRIX.') +C + 2000 CALL DGEMUL(YPN,N,'N',SCR,N,'N',YP,N,N,N,N) + CALL DGEMUL(F1N,N,'N',SCR,N,'N',F1,N,N,N,N) + CALL DGEMUL(F2N,N,'N',SCR,N,'N',F2,N,N,N,N) +C + RETURN + END + FUNCTION STEFF(X1,X2,IFLAG) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE D +C +C STEFFENSON ITERATION +C CONVERGENCE ACCELERATION FOR LINEAR CONVERGENCE +C + STEFF=X2 + IF(IFLAG.EQ.1) D=0.D0 + DEL=X2-X1 + IF(DEL.EQ.0.D0) RETURN + RINV=D/DEL + D=DEL + IF(ABS(RINV).LE.0.4D0) RETURN + STEFF=STEFF+DEL/(RINV-1.D0) + D=0.D0 + RETURN + END + SUBROUTINE STORAG(INTFLG,N,MXLAM,NV,NPOTL, + 1 ISJ,IS0,IS1,IS2,IS3,IS4,IS5,IS6,IS7,IS8,IS9, + 2 ESHIFT,NOPMAX,DEEP,IK,ICODE,PRINT, NUMDER) +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + INTEGER PRINT + LOGICAL NUMDER +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C N.B. NIPR WAS NOT USED IN V11 STORAGE ROUTINE! SHOULD IT BE? +C + NSQ=N*N +C +C IC2 IS NEXT AVAILABLE LOCATION ... + IC2=IXNEXT + NUSED=0 +C +C SOLVE COUPLED EQUATIONS BY METHOD OF DEVOGELAERE +C + IF(INTFLG.EQ.2) THEN + IT1=IC2 + IT2=IT1+MXLAM + IT3=IT2+4*NSQ + IT4=IT3+2*NSQ + IT5=IT4+4*NSQ + IT6=IT5+NSQ + IT7=IT6+NSQ + IXNEXT=IT7+N + CALL CHKSTR(NUSED) +C + CALL DVSCAT(N,NSQ,MXLAM,NPOTL, + 1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7), + 2 X(IS8),X(IS9), + 3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5),X(IT6),X(IT7), + 4 ESHIFT,ICODE,PRINT) +C +C SOLVE COUPLED EQUATIONS BY WALKER-LIGHT R-MATRIX PROPAGATOR METHOD +C + ELSE IF(INTFLG.EQ.3) THEN + IT1=IC2 + IT2=IT1+MXLAM + IT3=IT2+NSQ + IT4=IT3+NSQ + IT5=IT4+N + IT6=IT5+N + IT7=IT6+N + IT8=IT7+N + IT9=IT8+N + IT10=IT9+N + IT11=IT10+N + IXNEXT=IT11+N + CALL CHKSTR(NUSED) +C + CALL RMTPRP(N,NSQ,MXLAM,NPOTL, + 1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7), + 2 X(ISJ),X(IS8),X(IS9), + 3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5),X(IT6),X(IT7),X(IT8), + 4 X(IT9),X(IT10),X(IT11), + 5 NOPMAX,DEEP,IK,ICODE,PRINT,NV,0) +C +C SOLVE COUPLED EQUATIONS BY LOG DERIVATIVE/VIVAS +C + ELSE IF(INTFLG.EQ.4 .OR. INTFLG.EQ.5) THEN + IT1=IC2 + IT2=IT1+MXLAM + IF(NUMDER) IT2=IT2+2*MXLAM + IT3=IT2+N + IT4=IT3+N + IT5=IT4+N + IT6=IT5+N + IVIV=1 + IF(INTFLG.EQ.5) IVIV=0 + IT7=IT6+N*IVIV + IT8=IT7+N*IVIV + IT9=IT8+N*IVIV + IT10=IT9+N*IVIV + IT11=IT10+N*IVIV + IT12=IT11+N*IVIV + IT13=IT12+N*IVIV + IT14=IT13+N*IVIV + IT15=IT14+N*IVIV + IT16=IT15+N*IVIV + IT17=IT16+N*IVIV + IT18=IT17+NSQ*IVIV + IT19=IT18+NSQ*IVIV + IT20=IT19+NSQ*IVIV + IT21=IT20+NSQ*IVIV + IT22=IT21+NSQ*IVIV + IT23=IT22+NSQ*IVIV + IT24=IT23+NSQ*IVIV + IXNEXT=IT24+NSQ*IVIV + CALL CHKSTR(NUSED) +C + CALL LDVIVS(N,NSQ,MXLAM,NPOTL, + 1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7), + 2 X(IS8),X(IS9), + 3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5),X(IT6),X(IT7),X(IT8), + 4 X(IT9),X(IT10),X(IT11),X(IT12),X(IT13),X(IT14), + 5 X(IT15),X(IT16),X(IT17),X(IT18),X(IT19),X(IT20),X(IT21), + 6 X(IT22),X(IT23),X(IT24), + 7 ICODE,PRINT) +C +C DIABATIC MODIFIED LOG DERIVATIVE ALGORITHM. +C + ELSE IF(INTFLG.EQ.6) THEN + IT1=IC2 + IT2=IT1+MXLAM + IT3=IT2+N + IT4=IT3+N + IT5=IT4+N + IXNEXT=IT5+N + CALL CHKSTR(NUSED) +C +C N.B. IT5 IS PASSED SO SPECIAL N=1 CODE CAN OVERLAY STORAGE + CALL DASCAT(N,NSQ,MXLAM,NPOTL, + 1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7), + 2 X(IS8),X(IS9), + 3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5), + 4 ICODE,PRINT, IT5 ) +C +C QUASIADIABATIC MODIFIED LOG DERIVATIVE ALGORITHM. +C + ELSE IF(INTFLG.EQ.7) THEN + IT1=IC2 + IT2=IT1+MXLAM + IT3=IT2+NSQ + IT4=IT3+NSQ + IT5=IT4+N + IT6=IT5+N + IT7=IT6+N + IT8=IT7+N + IT9=IT8+N + IXNEXT=IT9+N + CALL CHKSTR(NUSED) +C + CALL QASCAT(N,NSQ,MXLAM,NPOTL, + 1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7), + 2 X(IS8),X(IS9), + 3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5),X(IT6),X(IT7),X(IT8), + 4 X(IT9), + 5 ICODE,PRINT) +C +C HYBRID DMLD/AIRY ALGORITHM OF ALEXANDER AND MANOLOPOULOS +C + ELSE IF(INTFLG.EQ.8) THEN + IT1=IC2 + IT2=IT1+MXLAM + IT3=IT2+N + IT4=IT3+N + IT5=IT4+N + IT6=IT5+N + IT7=IT6+NSQ + IT8=IT7+NSQ + IT9=IT8+N + IU1=IT9+N + IXNEXT=IU1+N + CALL CHKSTR(NUSED) +C + CALL AXSCAT(N,NSQ,MXLAM,NPOTL, + 1 X(IS0),X(IS1),X(IS2),X(IS3),X(IS4),X(IS5),X(IS6),X(IS7), + 2 X(IS8),X(IS9), + 3 X(IT1),X(IT2),X(IT3),X(IT4),X(IT5), + $ X(IT6),X(IT7),X(IT8),X(IT9),X(IU1), + 4 ICODE,PRINT) +C + ELSE IF (INTFLG.EQ.-1) THEN +C +C SOLVE EQUATIONS BY WKB USING GAUSS-MEHLER INTEGRATION. +C ONLY GOOD FOR ONE-CHANNEL CASES +C + IF (N.EQ.1) GO TO 810 + WRITE(6,601) N + 601 FORMAT('0 ***** ERROR. WKB (INTFLG=-1) ONLY IMPLEMENTED FOR', + 1 ' ONE-CHANNEL CASE. TERMINATED WITH N =',I4) + STOP + 810 IT1=IC2 + IT2=IT1+1 + IT3=IT2+1 + IXNEXT=IT3+MXLAM + IF (NUMDER) IXNEXT=IXNEXT+2*MXLAM + CALL CHKSTR(NUSED) + CALL WKB(N,MXLAM,NPOTL,X(IT1),X(IS0),X(IS1),X(IT3),X(IS8), + 1 X(IS5),X(IS6),X(IT2),X(IS9),X(IS7),X(IS3),X(IS4), + 2 NUMDER,PRINT) +C + ELSE + WRITE(6,699) INTFLG + 699 FORMAT('0 STORAG CALLED WITH AN ILLEGAL INTFLG=',I4) + STOP + ENDIF +C +C WE ARE FINISHED WITH THIS TEMPORARY STORAGE; RESTORE IXNEXT. +C THIS IS CONSISTENT W/ V11 WHICH DID NOT MODIFY STORAG IC2 ARGUMENT +C HOWEVER, THIS MEANS THAT ONE CANNOT EXPECT ALLOCATED STORAGE +C TO BE RETAINED BEYOND A SCATTERING CALL + IXNEXT=IC2 + RETURN + END + SUBROUTINE STRY(NLB,NUB,N,ITRY,EIGNEW) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE ITOLD +C +C THIS TESTS TO SEE IF ALL THE OFF-DIAGONAL ELEMENTS OF THE +C EIGENVECTORS HAVE BECOME NEGLIGIBLE COMPARED TO VTOL +C + DIMENSION NLB(1),NUB(1) + DIMENSION EIGNEW(1) +C TOLERANCE TO DETERMINE DEGENERACY. + DATA EPSIL / 1.D-2/ +C STORE OLD VALUE OF ITRY + ITOLD = ITRY + IF(N.LE.1) GO TO 15 + DO 10 I=1,N +C TEST FOR DEGENERACY + IF(I.EQ.1) GO TO 8 + DIFF = ABS(EIGNEW(I)-EIGNEW(I-1)) +C IF NEARLY DEGENERATE, DON'T BOTHER TO CHECK OFF-DIAGONAL +C EIGENVECTOR COMPONENTS + IF(DIFF.LT.EPSIL ) GO TO 10 + IF(I.EQ.N) GO TO 9 +8 DIFF = ABS(EIGNEW(I)-EIGNEW(I+1)) + IF(DIFF.LT.EPSIL ) GO TO 10 +9 IF(NLB(I).NE.NUB(I)) GO TO 20 +10 CONTINUE +C IF THE FOLLOWING STATEMENT IS REACHED, ALL COMPONENTS ARE +C INDEED NEGLIGIBLE OR DEGENERATE +15 ITRY = 0 + GO TO 30 +C THIS IS REACHED WHEN AN ELEMENT IS TOO LARGE. +20 ITRY = -1 + RETURN +30 IF(ITOLD.EQ.0 .AND. ITRY.EQ.0) ITRY = 1 +C THIS MAKES SURE THAT THE ELEMENTS WERE ALSO NEGLIGIBLE AT THE +C LAST STEP. +C ITRY = 1 ON RETURN MEANS READY TO TRY FOR S-MATRIX CONVERGENCE + RETURN + END + LOGICAL FUNCTION STSRCH(LOG,LLOG,LSTR,N,I4) +C VERSION OF 21 MAR 95 + CHARACTER*1 LOG,LLOG,LSTR(N) + IF (N.LE.0) GO TO 9000 + DO 1000 I=1,N + IF (LSTR(I).NE.LOG.AND.LSTR(I).NE.LLOG) GO TO 1000 + I4=I + STSRCH=.TRUE. + RETURN + 1000 CONTINUE + 9000 STSRCH=.FALSE. + I4=0 + RETURN + END + SUBROUTINE SURBAS(JLEV, N, J, L, EINT, CENT, VL, IV, + 1 MXLAM, NPOTL, LAM, ERED, WVEC, LCNT, THETA, PHI, EMAXK) +C +C SUBROUTINE TO SET UP ATOM-SURFACE SCATTERING. +C THIS VERSION USES 2 ELEMENTS OF THE VL ARRAY FOR EACH PAIR OF +C BASIS FUNCTIONS, SO REQUIRES NPOTL=2 RETURNED FROM POTENL. +C COMMON BLOCK NPOT COMMUNICATES THIS TO POTENL +C VERSION 14 CMBASE +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + SAVE + INTEGER FIND + LOGICAL LCNT,LEVIN,EIN,HEX,ORTHOG,EQUIV + DIMENSION JLEV(1), J(1), L(1), EINT(1), CENT(1), + 1 WVEC(1), VL(1), IV(1), LAM(1) + COMMON/NPOT/NPTL + COMMON/CMBASE/ROTI(12),ELEVEL(1000),EMAX,WT(2),SPNUC,NLEVEL, + 1 JLEVEL(4000),J1MIN, + 2 J1MAX,J1STEP,IS1(10),J2MIN,J2MAX,J2STEP,IS2(10),JHALF,IDENT + 3 ,MXJL,MXEL + COMMON/LATSYM/HEX,ORTHOG,EQUIV + DATA BFCT/16.857630D0/ +C + SQUARE(A,B) = A*A + B*B + 2.D0*A*B*COSLAT +C +C ISYM IS A LABEL FOR THE TYPE OF SYMMETRIZATION: +C < 0 NO SYMMETRIZATION +C = 0 0 DEGREE SYMMETRIZATION FOR RECTANGULAR OR HEX LATTICE +C = 1 30 DEGREE SYMMETRIZATION FOR HEX LATTICE +C = 2 45 DEGREE SYMMETRIZATION FOR SQUARE LATTICE +C + ISYM = -1 + IF((HEX.OR.ORTHOG) .AND. ABS(PHI).LT.1.D-10) ISYM = 0 + IF(HEX .AND. ABS(MOD(PHI,60.D0)-30.D0).LT.1.D-10) ISYM = 1 + IF(ORTHOG .AND. EQUIV .AND. ABS(MOD(PHI,90.D0)-45.D0).LT.1.D-10) + 1 ISYM = 2 +C + PARA=SQRT(ERED)*SIN(THETA*PI/180.D0) + SINPHI=SIN(PHI*PI/180.D0) + COSPHI=COS(PHI*PI/180.D0) + XK2=PARA*SINPHI/SINLAT + XK1=PARA*COSPHI-XK2*COSLAT + IF(LCNT) GOTO 50 + WRITE(6,598)N,THETA,PHI,XK1,XK2 + 598 FORMAT(/I4,' CHANNEL BASIS FOR THETA =',F8.3,' PHI =',F8.3, + 1 ' DEGREES'/' CORRESPONDING TO K = (',2F10.6,' ) A-1') + IF(ISYM.GE.0) WRITE(6,599) + 599 FORMAT(' SYMMETRIZED BASIS USED FOR THESE ANGLES'/ + 1 ' NOTE THAT CALCULATED INTENSITIES FOR OUT-OF-PLANE BEAMS', + 2 ' ARE IMPLICITLY SUMMED OVER EQUIVALENT PAIRS') + IF(EMAXK.NE.EMAX) WRITE(6,600) EMAXK + 600 FORMAT(' BASIS FUNCTIONS LIMITED BY EMAXK =',F10.3) +C + 50 I=0 + N=0 + DO 200 N1=1,NLEVEL + J1=JLEV(N1+NLEVEL) + IF(ISYM.GE.0 .AND. 2*J1.LT.ISYM*JLEV(N1)) GOTO 200 + A=XK1+XH*DBLE(JLEV(N1)) + B=XK2+XK*DBLE(J1) + ECHAN=SQUARE(A,B) + IF(ECHAN*ESCALE.GT.EMAXK) GOTO 200 + N=N+1 + IF(LCNT) GOTO 200 + EINT(N)=ECHAN + DIF=ERED-ECHAN + WVEC(N)=SIGN(SQRT(ABS(DIF)),DIF) + J(N)=JLEV(N1+NLEV2) + L(N)=0 + CENT(N)=0.D0 + DO 100 M=1,N + N2=J(M) + J2=JLEV(N2+NLEVEL) + IF(ISYM.GE.0 .AND. 2*J2.LT.ISYM*JLEV(N2)) GOTO 100 + I=I+1 + I1=JLEV(N2)-JLEV(N1) + I2=J2-J1 + IV(I)=FIND(I1,I2,LAM,MXLAM) + VL(I)=1.D0 + IF(IV(I).EQ.0) VL(I)=0.D0 + I=I+1 + IV(I)=0 + VL(I)=0.D0 + IF(ISYM.LT.0) GOTO 100 + IF(2*J1.EQ.ISYM*JLEV(N1) .NEQV. 2*J2.EQ.ISYM*JLEV(N2)) + 1 VL(I-1)=VL(I-1)*ROOT2 + IF(2*J1.EQ.ISYM*JLEV(N1) .OR. 2*J2.EQ.ISYM*JLEV(N2)) GOTO 100 +C +C IDENTIFY FOURIER COMPONENT CONNECTING SIGMA(N1) TO N2 +C + GOTO(70,80),ISYM + I1=JLEV(N1) + IF(HEX) I1=I1-J1 + I2=-J1 + GOTO 90 + 70 I1=JLEV(N1) + I2=I1-J1 + GOTO 90 + 80 I1=J1 + I2=JLEV(N1) + 90 I1=JLEV(N2)-I1 + I2=J2-I2 + IV(I)=FIND(I1,I2,LAM,MXLAM) + VL(I)=1.D0 + IF(IV(I).EQ.0) VL(I)=0.D0 + 100 CONTINUE + 200 CONTINUE + RETURN +C +C + ENTRY SET8(LEVIN,EIN,NLEV,JLEV,URED) +C + NPTL=2 + ROOT2=SQRT(2.D0) + ESCALE=BFCT/URED +C + EMIN=0.D0 + PI=ACOS(-1.D0) + COSLAT=COS(ROTI(3)*PI/180.D0) + SINLAT=SIN(ROTI(3)*PI/180.D0) + ORTHOG = ABS(COSLAT).LT.1.D-8 + EQUIV = ABS(ROTI(1)-ROTI(2)).LT.1.D-8 + HEX = EQUIV .AND. ABS(COSLAT+0.5D0).LT.1.D-8 + XH=2.D0*PI/SINLAT/ROTI(1) + XK=2.D0*PI/SINLAT/ROTI(2) + WRITE(6,601)(ROTI(I),I=1,3),COSLAT + 601 FORMAT(' LATTICE LENGTHS ARE',F10.6,' AND',F10.6,' A'/ + 1 ' RECIPROCAL LATTICE ANGLE IS ',F10.3,' DEGREES,', + 2 ' COSINE =',F10.6/) +C + IF(LEVIN) GOTO 500 + WRITE(6,602)EMIN,EMAX,J1MAX,J2MAX + 602 FORMAT(' BASIS FUNCTIONS GENERATED WITH'/5X,'EMIN =',F10.3/ + 1 5X,'EMAX =',F10.3/5X,'G1MAX =',I10/5X,'G2MAX =',I10/) + N1MAX=SQRT(EMAX)/(SINLAT*XH) + N1MAX=MIN0(N1MAX,J1MAX) + NLEVEL=0 + DO 300 N1=-N1MAX,N1MAX + A=DBLE(N1)*XH + B=A*COSLAT + N2MAX=(ABS(B)+SQRT(EMAX+B*B-A*A))/XK + N2MAX=MIN0(N2MAX,J2MAX) + DO 300 N2=-N2MAX,N2MAX + B=DBLE(N2)*XK + E=SQUARE(A,B)*ESCALE + IF(E.LT.EMIN .OR. E.GT.EMAX) GOTO 300 + NLEVEL=NLEVEL+1 + JLEVEL(2*NLEVEL-1)=N1 + JLEVEL(2*NLEVEL) =N2 + ELEVEL(NLEVEL)=E + 300 CONTINUE +C +C SORT CHANNELS ON ENERGY FOR K=0 +C + DO 400 N1=1,NLEVEL + DO 400 N2=N1+1,NLEVEL + IF(ELEVEL(N2).GE.ELEVEL(N1)) GOTO 400 + E=ELEVEL(N1) + ELEVEL(N1)=ELEVEL(N2) + ELEVEL(N2)=E + I1=2*N1 + I2=2*N2 + I=JLEVEL(I1-1) + JLEVEL(I1-1)=JLEVEL(I2-1) + JLEVEL(I2-1)=I + I=JLEVEL(I1) + JLEVEL(I1)=JLEVEL(I2) + JLEVEL(I2)=I + 400 CONTINUE + GOTO 700 +C + 500 DO 520 N1=1,NLEVEL + DO 520 N2=N1+1,NLEVEL + 520 IF (JLEVEL(2*N1-1).EQ.JLEVEL(2*N2-1) + 1 .AND. JLEVEL(2*N1) .EQ.JLEVEL(2*N2)) GOTO 530 + GOTO 540 + 530 WRITE(6,603)N1,N2 + 603 FORMAT(' **** BASIS FUNCTIONS',I3,' AND',I3,' ARE THE SAME.', + 1 ' TERMINATING.') + STOP + 540 WRITE(6,604)NLEVEL + 604 FORMAT(' BASIS FUNCTIONS TAKEN FROM JLEVEL INPUT WITH NLEVEL =', + 1 I3) + 700 NLEV=NLEVEL + NLEV2=NLEV+NLEV + DO 800 I=1,NLEV + N1=JLEVEL(2*I-1) + N2=JLEVEL(2*I) + JLEV(I)=N1 + JLEV(I+NLEV)=N2 + JLEV(I+NLEV2)=I + IF(.NOT.LEVIN) GOTO 800 + A=DBLE(N1)*XH + B=DBLE(N2)*XK + ELEVEL(I)=SQUARE(A,B)*BFCT/URED + 800 CONTINUE +C + IF(EIN) WRITE(6,605) + 605 FORMAT(' *** NOTE. INPUT CHANNEL ENERGIES OVERWRITTEN BY VALUES', + 1 ' CALCULATED FROM LATTICE PARAMETERS'/) + RETURN + END + SUBROUTINE SWRITE(IU,N,S) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION S(N,N) +C + WRITE(IU) ((S(I,J),J=1,I),I=1,N) + RETURN +C + ENTRY SREAD(IU,N,S,IEND) + IEND=0 + READ(IU,END=9999) ((S(I,J),J=1,I),I=1,N) + DO 1000 I=1,N + DO 1000 J=1,I-1 + 1000 S(J,I)=S(I,J) + RETURN + 9999 IEND=1 + RETURN + END + SUBROUTINE SYMINV(A, IA, N, INERT) +C +C SIMULATES SYMINV SYMMETRIC MATRIX INVERTER WITH LAPACK CALLS +C THIS VERSION USES ONLY THE UPPER TRIANGLE OF A: +C NOT COMPATIBLE WITH MOLSCAT VERSION 11. +C JMH MAY 93 +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C + DIMENSION A(IA,N) +C + IT1=IXNEXT + IT2=IT1+(N+1)/NIPR + LWORK=MX-IT2+1 +C + NB=ILAENV(1,'DSYTRF','L',N,-1,-1,-1) + LWREQ=N*NB + IF(LWORK.LT.LWREQ) THEN + WRITE(6,100) LWORK,N,NB +100 FORMAT(' *** ERROR: ONLY',I5,' WORDS OF WORKSPACE AVAILABLE', + 1 ' IN SYMINV.'/' LAPACK ROUTINE DSYTRF NEEDS AT LEAST N*NB:', + 2 ' N =',I5,' AND NB =',I5,' ON THIS CALL.') + STOP + ENDIF +C + IXNEXT=IT2+LWREQ + NUSED=0 + CALL CHKSTR(NUSED) +C + CALL DSYTRF('L',N,A,IA,X(IT1),X(IT2),LWORK,INFO) +C + IF (INFO .NE. 0) THEN + WRITE (6,120) INFO +120 FORMAT(' *** ERROR IN DSYTRF: INFO =',I3) + STOP + END IF +C + INERT=0 +C CALL DSYNEG(A,X(IT1),N,INERT) +C + CALL DSYTRI('L',N,A,IA,X(IT1),X(IT2),INFO) +C + IF (INFO .NE. 0) THEN + WRITE (6,130) INFO +130 FORMAT(' *** ERROR IN DSYTRI: INFO =',I3) + STOP + END IF +C + IXNEXT=IT1 +C + RETURN + END + FUNCTION THREEJ (J1,J2,J3) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C COMPUTATION OF SPECIAL WIGNER 3J COEFFICIENT WITH +C VANISHING PROJECTIONS. SEE EDMONDS, P. 50. +C +C THIS VERSION EVALUATES BINOM AND PARITY IN-LINE +C SHOULD IMPROVE EFFICIENCY, ESPECIALLY ON CRAY; +C ALSO GIVES IMPROVEMENT ON AMDAHL (SG: 20 DEC 92) +C +C STATEMENT FUNCTION FOR DELTA ASSOCIATED W/ RACAH AND SIXJ SYMBOLS +C DELTA(I,J,K)= SQRT(1.D0/ ( BINOM(I+J+K+1,I+J-K) * +C 1 BINOM(K+K+1,I-J+K) * DBLE(K+J-I+1) ) ) +C + I1=J1+J2+J3 + IF (I1-2*(I1/2).NE.0) GO TO 8 + 1 I2=J1-J2+J3 + IF (I2) 8,2,2 + 2 I3=J1+J2-J3 + IF (I3) 8,3,3 + 3 I4=-J1+J2+J3 + IF (I4) 8,4,4 + 4 I5=I1/2 + I6=I2/2 + SIGN=1.D0 + IF (I5-2*(I5/2).NE.0) SIGN=-SIGN +C 7 THREEJ=SIGN*DELTA(J1,J2,J3)*BINOM(I5,J1)*BINOM(J1,I6) +C B1,B2 ARE BINOM ASSOCIATED W/ DELTA + N=J1+J2+J3+1 + M=J1+J2-J3 + NM = N-M + MNM = MIN(NM,M) + IF(MNM.LE.0) THEN + B1=1.D0 + ELSE + FN = N+1 + F = 0.D0 + B = 1.D0 + DO 101 I = 1,MNM + F = F+1.D0 + C = (FN-F)*B + 101 B = C/F + B1 = B + ENDIF + N=J3+J3+1 + M=J1-J2+J3 + NM = N-M + MNM = MIN(NM,M) + IF(MNM.LE.0) THEN + B2=1.D0 + ELSE + FN = N+1 + F = 0.D0 + B = 1.D0 + DO 102 I = 1,MNM + F = F+1.D0 + C = (FN-F)*B + 102 B = C/F + B2 = B + ENDIF + DELTA=SQRT(1.D0/(B1*B2*(J3+J2-J1+1))) +C B3=BINOM(I5,J1), B4=BINOM(J1,I6) + N=I5 + M=J1 + NM = N-M + MNM = MIN(NM,M) + IF(MNM.LE.0) THEN + B3=1.D0 + ELSE + FN = N+1 + F = 0.D0 + B = 1.D0 + DO 103 I = 1,MNM + F = F+1.D0 + C = (FN-F)*B + 103 B = C/F + B3 = B + ENDIF + N=J1 + M=I6 + NM = N-M + MNM = MIN(NM,M) + IF(MNM.LE.0) THEN + B4=1.D0 + ELSE + FN = N+1 + F = 0.D0 + B = 1.D0 + DO 104 I = 1,MNM + F = F+1.D0 + C = (FN-F)*B + 104 B = C/F + B4 = B + ENDIF + THREEJ=SIGN*DELTA*B3*B4 + RETURN + 8 THREEJ=0.D0 + RETURN + END + FUNCTION THRJ(F1,F2,F3,G1,G2,G3) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C SMALL CHANGES 31 JUL 95 (SG) + SAVE MUNG,X,Y + PARAMETER (MXIX=302) + DIMENSION X(MXIX),Y(MXIX) + DATA MUNG/0/ + IF (MUNG.EQ.21) GO TO 69 + MUNG = 21 + X(1) = 0.D0 + DO 100 I = 1, MXIX-1 + A = I + X(I+1) = LOG(A) +X(I) + Y(I+1) = LOG(A) + 100 CONTINUE + 69 IF(F1-ABS(G1)) 1,13,13 + 13 IF(F2-ABS(G2))1,14,14 + 14 IF(F3-ABS(G3))1,15,15 + 15 SUM=F1+F2+F3 + NSUM=SUM+.001D0 + IF(SUM-NSUM)2,2,1 + 1 THRJ=0.D0 + RETURN + 2 IF(ABS(G1+G2+G3)-1.D-08)3,3,1 + 3 IF(F1+F2-F3)1,4,4 + 4 IF(F1+F3-F2)1,5,5 + 5 IF(F2+F3-F1)1,6,6 + 6 J1=2.D0*F3+2.001D0 + J2=F1+F2-F3+1.001D0 + J3=F1-F2+F3+1.001D0 + J4=-F1+F2+F3+1.001D0 + J5=F1+F2+F3+2.001D0 + J6=F1+G1+1.001D0 + J7=F1-G1+1.001D0 + J8=F2+G2+1.001D0 + J9=F2-G2+1.001D0 + J10=F3+G3+1.001D0 + J11=F3-G3+1.001D0 + IF(J5.GT.MXIX) THEN + WRITE(6,601) J5,MXIX + 601 FORMAT(' *** DIMENSION ERROR IN THRJ - INDEX.GT.MXIX',2I5) + STOP + ENDIF + R=0.5D0*(Y(J1)+X(J2)+X(J3)+X(J4)-X(J5) + 1+X(J6)+X(J7)+X(J8)+X(J9)+X(J10)+X(J11)) + SUM=0.D0 + F=-1 + KZ=-1 + 7 KZ=KZ+1 + F=-F + J1=KZ+1 + J2=F1+F2-F3-KZ+1.001D0 + IF(J2)20,20,8 + 8 J3=F1-G1-KZ+1.001D0 + IF(J3)20,20,9 + 9 J4=F2+G2-KZ+1.001D0 + IF(J4)20,20,10 + 10 J5=F3-F2+G1+KZ+1.001D0 + IF(J5)7,7,11 + 11 J6=F3-F1-G2+KZ+1.001D0 + IF(J6)7,7,12 + 12 JMAX=MAX(J1,J2,J3,J4,J5,J6) + IF(JMAX.GT.MXIX) THEN + WRITE(6,601) JMAX,MXIX + STOP + ENDIF + S=-(X(J1)+X(J2)+X(J3)+X(J4)+X(J5)+X(J6)) + SUM=SUM+F*EXP(R+S) + GO TO 7 + 20 INT=ABS(F1-F2-G3)+0.0001D0 + VAL=((-1.D0)**INT)*SUM/SQRT(2.D0*F3+1.D0) + IF(ABS(VAL).LE.1.D-6) VAL=0.D0 + THRJ=VAL + RETURN + END + SUBROUTINE TRNSFM(T,W,A,N,ISTOP,ISYM) +C------------------------------------------------------------------- +C WRITTEN BY G. A. PARKER. +C MODIFIED TO USE BLAS BY J. M. HUTSON +C THIS ROUTINE TRANSFORMS THE MATRIX W INTO A NEW BASIS SET +C ISTOP=.TRUE. ==> RETURN AFTER A = TRANSPOSE(W) * T +C ISTOP=.FALSE. ==> CONTINUE TO FORM W = TRANSPOSE(T) * W * T +C ISYM =.TRUE. ==> FORCE THE RESULTING MATRIX TO BE SYMMETRIC. +C N IS THE DIMENSION OF THE MATRICES. +C------------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + LOGICAL ISTOP,ISYM + DIMENSION T(1),W(1),A(1) + DATA ZERO/0.D0/,HALF/0.5D0/,ONE/1.D0/ +C------------------------------------------------------------------- +C MULTIPLY THE TRANSPOSE OF THE MATRIX W TIMES T AND +C STORE THE RESULT INTO MATRIX A. +C------------------------------------------------------------------- + IF (N.EQ.1) GOTO 300 + IF (ISYM) GOTO 140 + CALL DGEMUL(W,N,'T',T,N,'N',A,N,N,N,N) + IF (ISTOP) RETURN +C------------------------------------------------------------------- +C MULTIPLY THE TRANSPOSE OF MATRIX A TIMES MATRIX +C T AND STORE THE RESULT INTO MATRIX W +C------------------------------------------------------------------- + CALL DGEMUL(A,N,'T',T,N,'N',W,N,N,N,N) + RETURN +C------------------------------------------------------------------- +C THIS IS REACHED ONLY WHEN W AND THE RESULT MATRIX ARE SYMMETRIC, +C SO THAT ONLY HALF THE MATRIX NEED BE COMPUTED +C AND THE OTHER HALF STORED BY SYMMETRY. +C------------------------------------------------------------------- + 140 CALL DSYMM('L','L',N,N,ONE,W,N,T,N,ZERO,A,N) + IF (ISTOP) RETURN + CALL DSYR2K('L','T',N,N,HALF,A,N,T,N,ZERO,W,N) + CALL DSYFIL('U',N,W,N) + RETURN +C + 300 A(1)=W(1)*T(1) + IF (ISTOP) RETURN + W(1)=A(1)*T(1) + RETURN + END + SUBROUTINE TRNSP(A,N) +C +C SUBROUTINE FOR IN-PLACE TRANSPOSITION OF N X N MATRIX A +C BASED ON MILLARD ALEXANDER'S TRANSP +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION A(1) + ICOLPT = 2 + IROWPT = N + 1 + DO 100 ICOL = 1, N - 1 +C ICOLPT POINTS TO FIRST SUB-DIAGONAL ELEMENT IN COLUMN ICOL +C IROWPT POINTS TO FIRST SUPER-DIAGONAL ELEMENT IN ROW ICOL +C NROW IS NUMBER OF SUBDIAGONAL ELEMENTS IN THIS COLUMN + NROW = N - ICOL + CALL DSWAP (NROW, A(ICOLPT), 1, A(IROWPT), N) + ICOLPT = ICOLPT + N + 1 + IROWPT = IROWPT + N + 1 + 100 CONTINUE + RETURN + END + SUBROUTINE VINIT(I,RM,EPSIL) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + RM=.529177D0 + EPSIL=219474.63D0 +c ENTRY VSTAR (I,RR,SUM) +c ENTRY VSTAR1(I,RR,SUM) +c ENTRY VSTAR2(I,RR,SUM) +c WRITE(6,601) I +c 601 FORMAT('0 *** ERROR. DUMMY VERSION OF VINIT CALLED WITH I =', +c 1 I4/14X,'VINIT MUST BE PROVIDED IF NTERM(I) IS ZERO.') +c STOP + END + SUBROUTINE VIVAS(N,NSQ,DRNOW,RMIN,RMAX,DRMAX,TLDIAG,TOFF, + X ESHIFT,RMAT,EYE11,EYE12,EYE22,W,W0,W1,W2,TSTORE, + X VECOLD,VECNEW,G1,G1P,G2,G2P,A1,A1P,B1,B1P, + X XSQ,XK,COSX,SINX,SINE,DIAG,NOPEN,PRNTLV,ISC, + X P,VL,IVL,ERED,EINT,CENT,RMLMDA,MXLAM,WKS,NPOTL) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C------------------------------------------------------------------ +C MODIFIED FROM NRCC CODE FOR COMPATIBILITY WITH MOLSCAT +C BY S. GREEN (FEB. 1981) AND J.M. HUTSON (OCT. 1984) +C APR 87 MODIFY WARNING OUTPUT ASSOC. W/ 1800 FORMAT +C------------------------------------------------------------------ +C ROUTINES USED +C WAVMAT -CALCULATES THE POTENTIAL ENERGY INTERACTION MATRIX +C DERMAT -CALCULATES THE FIRST AND SECOND DERIVATIVES OF THE POTENTIAL +C TRNSFM -TRANSFORMS MATRICES INTO THE NEW BASIS VIA A +C SIMILARITY TRANSFORMATION +C PERT1 -CALCULATES THE PERTURBATION CORRECTIONS TO THE +C PERT2 WAVEFUNCTONS. +C DGESV -SOLVES A LINEAR SYSTEMS OF EQUATIONS. +C DELRD -PREDICTS THE NEW STEP SIZE. +C F02ABF -DIAGONALIZES A REAL SYMMETRIC MATRIX AND RETURN THE +C EIGENVALUES AND EIGENVECTORS. +C------------------------------------------------------------------ +C ON ENTERING +C N - NUMBER OF CHANNELS +C NSQ - N*N +C DRNOW - INITIAL STEP SIZE +C RMIN - MINIMUM RADIAL DISTANCE +C RMAX - MAXIMUM RADIAL DISTANCE +C DRMAX - MAXIMUM ALLOWED STEP SIZE +C TLDIAG- STEP TOLERANCE PARAMETER +C TOFF - INTERVAL TOLERANCE PARAMETER +C ISC - SCRATCH UNIT USED IF IREAD/IWRITE IS TRUE +C-------------------------------------------------------------------- +C PRINT LEVEL FOR MOLSCAT + INTEGER PRNTLV +C------------------------------------------------------------------ +C CHARACTER VARIABLES +C------------------------------------------------------------------ + CHARACTER*4 LRMAT,LUDP,LUD,LDG2P,LDG2,LDG1P,LDG1,LG2P, + 1 LG2,LG1P,LG1,LW0,LW2,LVECNW,LDIAG,LW1,LEYE11,LEYE12,LEYE22 +C------------------------------------------------------------------- +C LOGICAL VARIABLES +C------------------------------------------------------------------- + LOGICAL IVD,IVPD,IVPPD,IALFP,NUMDER + LOGICAL IVECT,IPOTL,IEYE,IGZRO,IGPERT,IWAVE,IRMAT,ITHS + LOGICAL ITRUE,IFALSE,NEWINT + LOGICAL IV,IVP,IVPP,ISHIFT,IREAD,IDIAG,IWRITE,ICRMAT + LOGICAL IPERT,LAST,ISYM +C------------------------------------------------------------------- +C LABELLED COMMONS +C CONTROL VARIABLES PASSED FROM DRIVER +C------------------------------------------------------------------- + COMMON/LDVVCM/ XSQMAX,ALPHA1,ALPHA2,IALPHA,IALFP,IV,IVP,IVPP, + 1 NUMDER,ISHIFT,IDIAG,IPERT,ISYM,IREAD,IWRITE +C------------------------------------------------------------------- +C IF THE LOGICAL VARIABLE IS TRUE THEN +C IV - CALCULATES PERTURBATION CORRECTIONS FROM THE CONSTANT +C TERMS IN THE INTERACTION POTENTIAL. +C IVP - CALCULATES PERTURBATION CORRECTIONS FROM THE FIRST +C DERIVATIVE OF THE INTERACTION POTENTIAL. +C IVPP - CALCULATES PERTURBATION CORRECTIONS FROM THE SECOND +C DERIVATIVE OF THE INTERACTION POTENTIAL. +C ISHIFT- SHIFTS THE REFERENCE POTENTIAL TO BEST FIT THE TRUE +C POTENTIAL. +C NUMDER- CALCULATES POTENTIAL DERIVATIVES NUMERICALLY +C IDIAG - INCLUDES ALL OF THE DIAGONAL PERTUBATION CORRECTIONS. +C ISYM - SYMMETRIZES THE R-MATRIX AT EACH INTERVAL. +C IPERT - USES THE PERTURBATIONS CORRECTIONS. +C IALFP - THE GEOMETRIC PROGRESSION PARAMETER ALPHA IS PREDICTED. +C ALPHA1- MINIMUM GEOMETRIC PROGRESSION PARAMETER. +C ALPHA2- MAXIMUM GEOMETRIC PROGRESSION PARAMETER. +C IALPHA- IF IALPHA.GT.0 THEN THE STEP SIZE IS DETERMINED USING +C A GEOMETRIC PROGRESSION AND THE INTERVAL IS DIVIDED +C INTO IALPHA STEPS. +C------------------------------------------------------------------ + COMMON/POPT/IVECT,IPOTL,IEYE,IGZRO,IGPERT,IWAVE,IRMAT,IOC + LOGICAL LPOPT(7) + EQUIVALENCE (LPOPT(1),IVECT) +C LPOPT CONTAINS PRINTING OPTIONS FROM NRCC VERSION. +C THESE ARE ALL SET FALSE HERE. CHANGE TO DEBUG. +C WHEN THE LOGICAL VARIABLE IS TRUE, +C IVECT - EIGENVALUES AND EIGENVECTORS. +C IPOTL - POTENTIAL ENERGY MATRICES AND ITS DERIVATIVES. +C IEYE - ACCUMULATED PERTURBATION INTEGRALS. +C IGZRO - ZERO-TH ORDER WAVEFUNCTIONS. +C IGPERT- PERTURBED WAVEFUNCTIONS. +C IWAVE - PERTURBED WAVEFUNCTIONS. +C IRMAT - R-MATRIX +C IOC - INFORMATION PRINTED EVERY IOC-TH STEP +C-------------------------------------------------------------------- +C ARRAYS DIMENSIONED AS VECTORS +C------------------------------------------------------------------- + DIMENSION G1(N),G1P(N),G2(N),G2P(N) + DIMENSION A1(N),A1P(N),B1(N),B1P(N) + DIMENSION XSQ(N),XK(N),COSX(N),SINX(N),SINE(N),DIAG(N) +C------------------------------------------------------------------- +C ARRAYS DIMENSIONED AS MATRICES +C------------------------------------------------------------------- + DIMENSION EYE11(NSQ),EYE12(NSQ),EYE22(NSQ) + DIMENSION W0(NSQ),W1(NSQ),W2(NSQ),W(NSQ) + DIMENSION RMAT(NSQ) + DIMENSION TSTORE(NSQ),VECOLD(NSQ),VECNEW(NSQ) + DIMENSION P(MXLAM),VL(2),IVL(2),EINT(N),CENT(N),WKS(N) +C------------------------------------------------------------------- +C DATA STATEMENTS FOR PRINTING +C------------------------------------------------------------------- + DATA LRMAT/'RMAT'/,LUDP/' UP'/,LUD/' U'/,LDG2P/'DG2P'/ + DATA LDG2/' DG2'/,LDG1P/'DG1P'/,LDG1/' DG1'/,LG2P/' G2P'/ + DATA LG2/' G2'/,LG1P/' G1P'/,LG1/' G1'/,LW0/' W0'/ + DATA LW2/' W2'/,LVECNW/'VCNW'/,LDIAG/'DIAG'/ + DATA LW1/' W1'/,LEYE11/' I11'/,LEYE12/' I12'/,LEYE22/' I22'/ +C------------------------------------------------------------------- +C LOGICAL DATA STATEMENTS +C------------------------------------------------------------------- + DATA IFALSE/.FALSE./,ITRUE/.TRUE./ +C------------------------------------------------------------------- +C +C SET DEFAULT VALUES FOR PRINTING + NSGERR=0 + IOC=5 + DO 100 I=1,7 + 100 LPOPT(I)=.FALSE. + IF(.NOT.(IREAD.AND.IWRITE)) GO TO 101 + WRITE(6,699) + 699 FORMAT('0 * * * ERROR. IREAD AND IWRITE CANNOT BOTH BE TRUE.') + IREAD=.FALSE. + IWRITE=.FALSE. + 101 CONTINUE + IVD = IV .OR. IDIAG + IVPD = IVP .OR. IDIAG + IVPPD = IVPP .OR. IDIAG +C------------------------------------------------------------------- +C PRINT CONTROL DATA + IF(PRNTLV.LE.15) GO TO 110 + WRITE(6,1200) + WRITE(6,1300) IVECT,IPOTL,IEYE,IGZRO,IGPERT,IWAVE,IRMAT, + X IWRITE,IREAD,IOC + WRITE(6,1400) + WRITE(6,1500) IV,IVP,IVPP,ISHIFT,IDIAG,ISYM,IPERT,IALFP + WRITE(6,1600) ALPHA1,ALPHA2,IALPHA + WRITE(6,2500) + WRITE(6,2600) RMIN,RMAX,DRNOW,DRMAX,TOFF,TLDIAG + 110 COFFL = 0.D0 + IF(N .EQ. 0) RETURN + NEWINT = .FALSE. + NP1 = N+1 + ICRMAT = .TRUE. + TOL = 1.D-11 + LAST = .FALSE. + ITRANS = 0 + IK = 0 + DO 130 I = 1,N + G1(I) = 0.D0 + G1P(I) = 1.D0 + G2(I) = 1.D0 + G2P(I) = 0.D0 + DO 130 K = 1,N + IK = IK+1 + VECNEW(IK) = 0.D0 + IF(I .EQ. K) VECNEW(IK) = 1.D0 + EYE11(IK) = 0.D0 + EYE12(IK) = 0.D0 + 130 EYE22(IK) = 0.D0 + IF(PRNTLV.GE.15) WRITE(6,3100) + ISTEP = 1 + NTRVL = 0 + DINT = DRNOW + DIAGI = RMIN+0.5D0*DINT + RMID = RMIN + RLAST = RMIN + XBAR = 0.D0 + XSBAR = 0.D0 + EBAR = 0.D0 + EXBAR = 0.D0 + IF(IALPHA .LE. 0) GO TO 150 + BALPHA = (ALPHA2-ALPHA1)/(RMAX-RMIN) + ALPHA = ALPHA1+BALPHA*(DIAGI-RMIN) + IF(IALFP) ALPHA = ALPHA1 + IF(ALPHA .NE. 1.D0) GO TO 140 + DRNOW = DINT/IALPHA + GO TO 150 + 140 DRNOW = DINT*(ALPHA-1.D0)/(ALPHA**IALPHA-1.D0) + 150 RNOW = RMIN+DRNOW + IF(IWRITE) WRITE(ISC) RMIN,RMAX,DINT,DIAGI,RMID,IALPHA,BALPHA, + X ALPHA1,ALPHA2,IALPHA + IF(.NOT. IREAD) GO TO 160 + READ(ISC) RMIN,RMAX,DINT,DIAGI,RMID,IALPHA,BALPHA, + X ALPHA1,ALPHA2,IALPHA +C------------------------------------------------------------------- +C START OF THE PROPAGATION LOOP +C------------------------------------------------------------------- + 155 READ(ISC) ISTEP,RNOW,DRNOW,LAST,N,DIAG,TSTORE, + X W0,W1,W2,VECNEW,NTRVL,RMIDI,RLAST,RCENT,ITRANS + READ(ISC) NEWINT + DO 158 I=1,N + 158 DIAG(I)=DIAG(I)+ESHIFT + 160 RCENT = RNOW-0.5D0*DRNOW + ITHS = .FALSE. + IF(((NTRVL+1)/IOC)*IOC .EQ. NTRVL+1) ITHS = .TRUE. + IF(IREAD) GO TO 300 +C------------------------------------------------------------------- +C EVALUATE THE POTENTIAL AND ITS DERIVATIVES. +C------------------------------------------------------------------- + CALL WAVMAT(W,N,RCENT, + 1 P,VL,IVL,ERED,EINT,CENT,RMLMDA,WKS,MXLAM,NPOTL) + DO 165 I = 1, NSQ + 165 W0(I) = W(I) + IF(IVPD .AND. IVPPD) GO TO 200 + DO 170 I = 1, NSQ + W1(I) = 0.D0 + 170 W2(I) = 0.D0 + 200 IF(IVPPD .OR. ISHIFT) CALL DERMAT(2,W2,N,RCENT, + 1 P,VL,IVL,CENT,RMLMDA,MXLAM,NPOTL,NUMDER) + IF (IVPD) CALL DERMAT(1,W1,N,RCENT, + 1 P,VL,IVL,CENT,RMLMDA,MXLAM,NPOTL,NUMDER) + FACTOR = DRNOW*DRNOW/24.D0 + IF( .NOT. ISHIFT) FACTOR = 0.D0 + IF( .NOT. ICRMAT) GO TO 270 + RMIDI = DIAGI +C------------------------------------------------------------------- +C EVALUATE THE POTENTIAL AT THE RMIDI WHERE THE INTERACTION IS TO +C BE DIAGONALIZED AND SAVE THE OLD EIGENVECTORS. +C------------------------------------------------------------------- + IF(RMIDI .NE. RCENT) CALL WAVMAT(W,N,RMIDI, + 1 P,VL,IVL,ERED,EINT,CENT,RMLMDA,WKS,MXLAM,NPOTL) + DO 240 I = 1,NSQ + 240 VECOLD(I) = VECNEW(I) + ITRANS = ITRANS+1 +C------------------------------------------------------------------- +C DIAGONALIZE THE INTERACTION POTENTIAL. +C------------------------------------------------------------------- + IFAIL=0 + CALL F02ABF(W,N,N,DIAG,VECNEW,N,WKS,IFAIL) + IF( .NOT. ITHS) GO TO 270 + IF( .NOT. IVECT) GO TO 270 + WRITE(6,2900) LDIAG + WRITE(6,2800) (DIAG(I),I = 1,N) + WRITE(6,2900) LVECNW + WRITE(6,2800) (VECNEW(I),I = 1,NSQ) +C-------------------------------------------------------------------- +C TRANSFORM THE POTENTIAL AND ITS DERIVATIVES INTO THE LOCAL BASIS. +C-------------------------------------------------------------------- + 270 CALL TRNSFM(VECNEW,W0,TSTORE,N,IFALSE,ITRUE) + IF(IVPD) CALL TRNSFM(VECNEW,W1,TSTORE,N,IFALSE,ITRUE) + IF(IVPPD .OR. ISHIFT) CALL TRNSFM(VECNEW,W2,TSTORE,N,IFALSE, + X ITRUE) +C------------------------------------------------------------------- +C DETERMINE THE NEW TRANSFORMATION MATRIX +C------------------------------------------------------------------- + IF(ICRMAT) CALL DGEMUL(VECOLD,N,'T',VECNEW,N,'N',TSTORE,N,N,N,N) +C------------------------------------------------------------------- +C TRANSFORM THE R-MATRIX INTO THE NEW BASIS. +C------------------------------------------------------------------- + 300 IF(ICRMAT) CALL TRNSFM(TSTORE,RMAT,W,N,IFALSE,ISYM) + ICRMAT = .FALSE. + IF(IREAD) GO TO 350 +C------------------------------------------------------------------- +C SHIFT THE EIGENVALUES AND INITIALIZE FOR CONTRIBUTIONS NOT DESIRED. +C------------------------------------------------------------------- + INDEX = -N + DO 330 J = 1,N + INDEX = INDEX+NP1 + DIAG(J) = -W0(INDEX)-FACTOR*W2(INDEX) + 330 W0(INDEX) = -FACTOR*W2(INDEX) + IF(IVD .AND. IVPD .AND. IVPPD) GO TO 350 + CTERM0 = 1.D0 + CTERM1 = 1.D0 + CTERM2 = 1.D0 + IF( .NOT. IVD) CTERM0 = 0.D0 + IF( .NOT. IVPD) CTERM1 = 0.D0 + IF( .NOT. IVPPD) CTERM2 = 0.D0 + DO 340 I = 1,NSQ + W0(I) = W0(I)*CTERM0 + W1(I) = W1(I)*CTERM1 + 340 W2(I) = W2(I)*CTERM2 +C------------------------------------------------------------------- +C WRITE ON UNIT ISC THE INFORMATION NECESSARY FOR SUBSEQUENT ENERGY +C CALCULATIONS. +C------------------------------------------------------------------- + 350 IF(IWRITE) WRITE(ISC) ISTEP,RNOW,DRNOW,LAST,N,DIAG,TSTORE, + X W0,W1,W2,VECNEW,NTRVL,RMIDI,RLAST,RCENT,ITRANS + IF( .NOT. ITHS) GO TO 360 + IF( .NOT. IPOTL) GO TO 360 + WRITE(6,2900) LDIAG + WRITE(6,2800) (DIAG(I),I = 1,N) + WRITE(6,2900) LW0 + WRITE(6,2800) (W0(I),I = 1,NSQ) + WRITE(6,2900) LW1 + WRITE(6,2800) (W1(I),I = 1,NSQ) + WRITE(6,2900) LW2 + WRITE(6,2800) (W2(I),I = 1,NSQ) + WRITE(6,2900) IALPHA +C------------------------------------------------------------------- +C CALCULATE THE ZERO-TH ORDER WAVEFUNCTIONS AND DERIVATIVES. +C------------------------------------------------------------------- + 360 NOPLOC = 0 + DO 390 I = 1,N + DIF = DIAG(I) + XSQ(I) = DIF*DRNOW*DRNOW + XLMBDA = SQRT(ABS(DIF)) + X = XLMBDA*DRNOW + IF(DIF .LT. 0.D0) GO TO 370 + NOPLOC = NOPLOC+1 + SX = SIN(X)/XLMBDA + CX = COS(X) + GO TO 380 + 370 IF(X.GT.173.D0) WRITE(6,1700) I,DIF,DRNOW,X + SX = SINH(X)/XLMBDA + CX = COSH(X) + 380 A = G1P(I) + SINX(I) = SX + SINE(I) = SX*XLMBDA + IF(DIF .LT. 0.D0) SINE(I) = -SINE(I) + COSX(I) = CX + XK(I) = X + B = G1(I) + G1(I) = A*SX+B*CX + G1P(I) = A*CX-DIF*B*SX + C = G2P(I) + D = G2(I) + A1(I) = B + A1P(I) = A + B1(I) = D + B1P(I) = C + G2(I) = C*SX+D*CX + 390 G2P(I) = C*CX-DIF*D*SX +C------------------------------------------------------------------- +C ESTIMATE G2P(N) AT END OF NEXT STEP. IF IT IS TOO LARGE, +C A NEW INTERVAL WILL BE STARTED. +C------------------------------------------------------------------- + IF(ABS(G2P(N)).LE.1.D04) GO TO 1801 + IF (PRNTLV.GT.3) WRITE(6,1800) RNOW,DRNOW,G2P(N) + NSGERR=NSGERR+1 + 1801 G2PMAX=G2P(N)*CX + IF(IREAD .AND. .NOT. IPERT) GO TO 410 +C------------------------------------------------------------------- +C CALCULATE THE INTEGRALS NECESSARY FOR THE PERTURBATION CORRECTIONS. +C THE STEP INTEGRALS ARE STORED IN W0, W1 AND W2, AND THE ACCUMULATED +C INTEGRALS OVER THE INTERVAL ARE SAVED IN EYE11, EYE12 AND EYE22. +C------------------------------------------------------------------- + IF(IVPP) CALL PERT2(N,COSX,SINE,XSQ,XK,DRNOW,W0,W1,W2,EYE11, + X EYE12,EYE22,A1,B1,A1P,B1P) + IF(IVPP) GO TO 400 + IF(IVP) CALL PERT1(N,COSX,SINE,XSQ,XK,DRNOW,W0,W1,W2,EYE11, + X EYE12,EYE22,A1,B1,A1P,B1P) + IF(IVP) GO TO 400 + IF(IV) CALL PERT2(N,COSX,SINE,XSQ,XK,DRNOW,W0,W1,W2,EYE11, + X EYE12,EYE22,A1,B1,A1P,B1P) + 400 CONTINUE + 410 IF(IREAD .AND. .NOT. NEWINT) GO TO 590 + SOFF = 0.D0 + COFF = 0.D0 + CDIAG = 0.D0 + SDIAG = 0.D0 +C------------------------------------------------------------------- +C THE FOLLOWING IS USED TO DETERMINE THE MAXIMUM PERTURBATION +C CORRECTIONS TO THE UNPERTURBED WAVEFUNCTIONS. SINCE THE STEP +C SIZE FOR SUBSEQUENT ENERGIES HAS ALREADY BEEN STORED ON DISK +C THIS INFORMATION IS NOT NECESSARY FOR SUBSEQUENT ENERGIES. +C------------------------------------------------------------------- + IF( .NOT. IPERT .AND. IREAD) GO TO 460 + IF(IREAD) GO TO 430 + DO 420 I = 1,N + A1(I) = 1.D0/SQRT(A1P(I)*A1P(I)/ABS(DIAG(I))+A1(I)*A1(I)) + B1(I) = 1.D0/SQRT(B1P(I)*B1P(I)/ABS(DIAG(I))+B1(I)*B1(I)) + A1P(I) = DRNOW*A1(I)/XK(I) + B1P(I) = DRNOW*B1(I)/XK(I) + SINE(I) = 1.D0 + IF(DIAG(I) .GT. 0.D0) GO TO 420 + EXPX = EXP(-XK(I)*DINT/DRNOW) + IF(DIAG(I).LT.-XSQMAX)EXPX=0.D0 + SINE(I) = EXPX + A1(I) = A1(I)*EXPX + B1(I) = B1(I)*EXPX + A1P(I) = A1P(I)*EXPX + B1P(I) = B1P(I)*EXPX + 420 CONTINUE + 430 IJ = 0 +C------------------------------------------------------------------- +C CALCULATE THE PERTURBATION CORRECTIONS TO THE WAVEFUNCTION AND +C ITS DERIVATIVE. +C------------------------------------------------------------------- + DO 450 J = 1,N + A1J = A1(J) + A1PJ = A1P(J) + DO 450 I = 1,N + JI = J+(I-1)*N + IJ = IJ+1 + PRT1 = G1(J)*EYE12(IJ)-G2(J)*EYE11(IJ) + PRT2 = G1(I)*EYE22(IJ)-G2(I)*EYE12(IJ) + PRT1P = G1P(J)*EYE12(IJ)-G2P(J)*EYE11(IJ) + PRT2P = G1P(I)*EYE22(IJ)-G2P(I)*EYE12(IJ) +C------------------------------------------------------------------- +C DON'T DETERMINE THE MAXIMUM PERTURBATION CORRECTION FOR +C SUBSEQUENT ENERGIES. +C------------------------------------------------------------------- + IF(IREAD) GO TO 440 + B1I = B1(I) + B1PI = B1P(I) + E1 = ABS(PRT1)*A1J + E2 = ABS(PRT2)*B1I + E3 = ABS(PRT1P)*A1PJ + E4 = ABS(PRT2P)*B1PI + IF(I .NE. J) COFF = MAX(COFF,E1,E2,E3,E4) + IF(I .EQ. J) CDIAG = MAX(CDIAG,E1,E2,E3,E4) + IF(J .GT. I) GO TO 440 + CCIJ = W0(IJ) + CCJI = W0(JI) + CSIJ = W1(IJ) + CSJI = W1(JI) + SSIJ = W2(IJ) + SSJI = W2(JI) + E1 = ABS(SINX(J)*CSJI-COSX(J)*SSIJ)*SINE(J)*XK(J)/DRNOW + E2 = ABS(SINX(I)*CCIJ-COSX(I)*CSJI)*SINE(I) + E3 = ABS(COSX(J)*CSJI+DIAG(J)*SINX(J)*SSIJ)*SINE(J) + E4 = ABS(COSX(I)*CCIJ+DIAG(I)*SINX(I)*CSJI)*SINE(I)*DRNOW/XK(I) + E5 = ABS(SINX(I)*CSIJ-COSX(I)*SSJI)*SINE(I)*XK(I)/DRNOW + E6 = ABS(SINX(J)*CCJI-COSX(J)*CSIJ)*SINE(J) + E7 = ABS(COSX(I)*CSIJ+DIAG(I)*SINX(I)*SSJI)*SINE(I) + E8 = ABS(COSX(J)*CCJI+DIAG(J)*SINX(J)*CSIJ)*SINE(J)*DRNOW/XK(J) + IF(I .NE. J) SOFF = MAX(SOFF,E1,E2,E3,E4,E5,E6,E7,E8) + IF(I .EQ. J) SDIAG = MAX(SDIAG,E1,E2,E3,E4,E5,E6,E7,E8) + 440 W2(IJ) = PRT1 + W(JI) = PRT2 + W0(IJ) = PRT1P + 450 W1(JI) = PRT2P + IF(SOFF.EQ.0.D0) SOFF=1.D-30 + IF(IPERT) GO TO 480 + 460 DO 470 I = 1,NSQ + W2(I) = 0.D0 + W0(I) = 0.D0 + W(I) = 0.D0 + 470 W1(I) = 0.D0 + 480 IF(LAST) GO TO 500 + IF(IALPHA.LE.0) GO TO 485 + IF((ISTEP/IALPHA)*IALPHA.EQ.ISTEP) GO TO 500 + GO TO 590 +C------------------------------------------------------------------- +C ARRIVE HERE ONLY FOR IALPHA.EQ.0 OPTION. +C START NEW INTERVAL IF PREDICTED G2P FOR NEXT STEP IS TOO LARGE +C------------------------------------------------------------------- + 485 IF(.NOT.IREAD .AND. ABS(G2PMAX).GT.1.D04) GO TO 500 + IF(COFFL .EQ. 0.D0) GO TO 490 + FACC = COFF/COFFL + FACS = SOFF/SOFF1 + IF(FACC .GT. 2.D0) FACC = 2.D0 + IF(FACS .GT. 2.D0) FACS = 2.D0 + IF(FACC*COFF .GT. 0.8D0*TOFF) GO TO 500 + IF(FACS*SOFF .GT. 0.8D0*TLDIAG) GO TO 500 + 490 COFFL = COFF + SOFF1 = SOFF + SDIAG1 = SDIAG + COFFL = COFF + IF(IREAD .AND. NEWINT) GO TO 500 +C------------------------------------------------------------------- +C CHECK TO SEE IF THE PERTURBATION CORRECTIONS ARE LARGE ENOUGH +C TO WARRANT A NEW INTERVAL AND BASIS SET TRANSFORMATION. +C------------------------------------------------------------------- + IF(COFF .LT. 0.8D0*TOFF .AND. CDIAG .LT. 0.8D0*TOFF) GO TO 590 + 500 COFFL = 0.D0 + SOFF1 = SOFF + SDIAG1 = SDIAG + ICRMAT = .TRUE. + IF( .NOT. ITHS) GO TO 510 + IF( .NOT. IEYE) GO TO 510 + WRITE(6,2900) LEYE11 + WRITE(6,2800) (EYE11(I),I = 1,NSQ) + WRITE(6,2900) LEYE12 + WRITE(6,2800) (EYE12(I),I = 1,NSQ) + WRITE(6,2900) LEYE22 + WRITE(6,2800) (EYE22(I),I = 1,NSQ) +C------------------------------------------------------------------- +C MULTIPLY THE OLD R-MATRIX TIMES IRREGULAR WAVEFUNCTION AND ITS +C PERTURBATION CORRECTION. +C------------------------------------------------------------------- + 510 NP1 = N+1 + II = 1 + DO 520 I = 1,N + W0(II) = W0(II)+G1P(I) + W1(II) = W1(II)+G2P(I) + W2(II) = W2(II)+G1(I) + W(II) = W(II)+G2(I) + 520 II = II+NP1 + CALL DCOPY(NSQ,W0,1,TSTORE,1) + CALL DSYMM('L','L',N,N,1.D0,RMAT,N,W1,N,1.D0,TSTORE,N) + CALL DCOPY(NSQ,W2,1,VECOLD,1) + CALL DSYMM('L','L',N,N,1.D0,RMAT,N,W ,N,1.D0,VECOLD,N) + IF( .NOT. ITHS) GO TO 550 + IF( .NOT. IGZRO) GO TO 540 + WRITE(6,2900) LG1 + WRITE(6,2800) (G1(I),I = 1,N) + WRITE(6,2900) LG1P + WRITE(6,2800) (G1P(I),I = 1,N) + WRITE(6,2900) LG2 + WRITE(6,2800) (G2(I),I = 1,N) + WRITE(6,2900) LG2P + WRITE(6,2800) (G2P(I),I = 1,N) + 540 IF( .NOT. IGPERT) GO TO 550 + WRITE(6,2900) LDG1 + WRITE(6,2800) (W2(I),I = 1,NSQ) + WRITE(6,2900) LDG1P + WRITE(6,2800) (W0(I),I = 1,NSQ) + WRITE(6,2900) LDG2 + WRITE(6,2800) (W(I),I = 1,NSQ) + WRITE(6,2900) LDG2P + WRITE(6,2800) (W1(I),I = 1,NSQ) + 550 IF( .NOT. ITHS) GO TO 560 + IF( .NOT. IWAVE) GO TO 560 + WRITE(6,2900) LUD + WRITE(6,2800) (EYE12(I),I = 1,NSQ) + WRITE(6,2900) LUDP + WRITE(6,2800) (EYE11(I),I = 1,NSQ) + 560 IER = 0 +C------------------------------------------------------------------- +C SOLVE A LINEAR SYSTEM OF EQUATIONS TO DETERMINE THE NEW R-MATRIX +C------------------------------------------------------------------- + CALL DGESV(N,N,TSTORE,N,WKS,VECOLD,N,IER) +C------------------------------------------------------------------- +C REINITIALIZE FOR THE NEXT INTERVAL. STORE THE NEW R-MATRIX IN RMAT. +C------------------------------------------------------------------- + DO 570 I = 1,N + G1(I) = 0.D0 + G2(I) = 1.D0 + G1P(I) = 1.D0 + G2P(I) = 0.D0 + DO 570 J = 1,N + IJ = I+(J-1)*N + JI = J+(I-1)*N + RMAT(JI) = VECOLD(IJ) + IF(ISYM) RMAT(JI) = 0.5D0*(VECOLD(IJ)+VECOLD(JI)) + EYE11(IJ) = 0.D0 + EYE12(IJ) = 0.D0 + 570 EYE22(IJ) = 0.D0 + NTRVL = NTRVL+1 + IF( .NOT. ITHS) GO TO 580 + IF( .NOT. IRMAT) GO TO 580 + WRITE(6,2900) LRMAT + WRITE(6,2800) (RMAT(I),I = 1,NSQ) + GO TO 590 + 580 CONTINUE + 590 CONTINUE + IF( .NOT. IWRITE) GO TO 600 + NEWINT=ICRMAT + WRITE(ISC) NEWINT +C------------------------------------------------------------------- +C WRITE THE MINIMAL STEP INFORMATION AND DETERMINE THE NEW STEP SIZE +C AND PREDICT THE NEW INTERVAL SIZE. +C------------------------------------------------------------------- + 600 IF(PRNTLV.GE.15) WRITE(6,2700) ITRANS,RMIDI,DRNOW,RLAST,RNOW, + X DIAG(1),DIAG(N),CDIAG,COFF,SDIAG,SOFF,ALPHA,NOPLOC,ISTEP + IF( .NOT. LAST) ISTEP = ISTEP+1 + IF(LAST) GO TO 670 + IF(IREAD) GO TO 155 + XBAR = XBAR+RNOW + XSBAR = XSBAR+RNOW*RNOW + EBAR = EBAR+SDIAG + EXBAR = EXBAR+RNOW*SDIAG + TMXX = 0.5D0*TOFF + IF(TLDIAG .GT. TMXX) TMXX = TLDIAG + IF(DINT.NE.DRNOW) SOFF = 0.8D0*TLDIAG*(SOFF/(0.8D0*TMXX))**1.5D0 + IF(IALPHA .GT. 0) DRNOW = DRNOW*ALPHA + IF(IALPHA. LE. 0) CALL DELRD(DRNOW,SDIAG,SOFF,TLDIAG,DRMAX, + 1 DIAG(1),DIAG(N),RNOW,RMAX) + IF( .NOT. ICRMAT) GO TO 650 + DINT = RNOW-RMID + DINT1 = DINT + IF(IALPHA.LE.0) GO TO 630 + XBAR = XBAR/IALPHA + XSBAR = XSBAR/IALPHA + EBAR = EBAR/IALPHA + EXBAR = EXBAR/IALPHA + IF(IALPHA.EQ.1) SLOPE=0.D0 + IF(IALPHA.NE.1) SLOPE = (EXBAR-XBAR*EBAR)/(XSBAR-XBAR*XBAR) + BINT = EBAR-XBAR*SLOPE + EMAX = BINT+SLOPE*RNOW + EMIN = BINT+SLOPE*(RNOW-DINT) + ALFNEW = ALPHA + IF(IALPHA .LE. 1) GO TO 630 + IF(EMAX.EQ.0.D0) EMAX=1.D-30 + FAC = EMIN/EMAX + IF(FAC .LE. 0.D0) GO TO 620 + FAC = (FAC)**(1.D0/DBLE(3*IALPHA-3)) + IF(FAC .GT. 1.1D0) FAC = 1.1D0 + IF(FAC .LT. 0.9D0) FAC = 0.9D0 + ALFNEW = ALPHA*FAC + GO TO 630 + 620 FAC = 1.1D0 + IF(EMIN .LE. 0.D0) FAC = 0.9D0 + ALFNEW = ALPHA*FAC + 630 XBAR = 0.D0 + XSBAR = 0.D0 + EBAR = 0.D0 + EXBAR = 0.D0 + TMXX = TOFF + IF(TLDIAG .GT. TOFF) TMXX = TLDIAG + IF(DINT.NE.DRNOW) COFF = 0.8D0*TMXX*(COFF/(0.8D0*TMXX))**1.5D0 + CALL DELRD(DINT,CDIAG,COFF,TMXX,DRMAX,DIAG(1),DIAG(N),RNOW,RMAX) + IF(DINT1.NE.DRNOW) SOFF1 = TLDIAG*(2.D0*SOFF1/TLDIAG)**1.5D0 + CALL DELRD(DINT1,SDIAG1,SOFF1,TLDIAG,DRMAX,DIAG(1),DIAG(N),RNOW, + 1 RMAX) + IF(ABS(DINT1) .LT. ABS(DINT)) DINT = DINT1 + IF(DINT .LT. DRNOW) DINT = DRNOW + IF(ABS(RMAX-RNOW-DINT) .LT. ABS(0.01D0*DINT)) DINT = RMAX-RNOW + IF((RMAX-RNOW-DINT)*DINT .LT. 0.D0) DINT = RMAX-RNOW + RMID = RNOW + DIAGI = RNOW+0.5D0*DINT + IF(IALPHA .LE. 0) GO TO 650 + ALPHA = ALPHA1+BALPHA*(DIAGI-RMIN) + IF(IALFP) ALPHA = ALFNEW + IF(ALPHA .NE. 1.D0) GO TO 640 + DRNOW = DINT/IALPHA + GO TO 650 + 640 DRNOW = DINT*(ALPHA-1.D0)/(ALPHA**IALPHA-1.D0) + 650 IF(ABS(RMAX-RNOW-DRNOW) .LT. ABS(0.01D0*DRNOW)) + 1 DRNOW = RMAX-RNOW + IF((RMAX-RNOW-DRNOW)*DRNOW .LT. 0.D0) DRNOW = RMAX-RNOW + RLAST = RNOW + RNOW = RNOW+DRNOW + DEL = (RNOW-RMAX)/DRNOW + IF(ABS(DEL) .LT. 0.005D0) LAST = .TRUE. + GO TO 160 +C------------------------------------------------------------------- +C THE INTEGRATION IS NOW COMPLETE. TRANSFORM THE R-MATRIX INTO THE +C ORIGINAL BASIS. +C------------------------------------------------------------------- + 670 NCOL = 1 + NLAST = N + DO 690 IR = 1,N + NORIG = IR + DO 680 NTRANS = NCOL,NLAST + VECOLD(NTRANS) = VECNEW(NORIG) + 680 NORIG = NORIG+N + NLAST = NLAST+N + 690 NCOL = NCOL+N + CALL TRNSFM(VECOLD,RMAT,TSTORE,N,IFALSE,ISYM) + IF(PRNTLV.GE.3) WRITE(6,3000) RMIN,RMAX,ISTEP + IF (PRNTLV.LE.3 .AND. NSGERR.GT.0) WRITE(6,1802) NSGERR + RETURN +C------------------------------------------------------------------- +C FORMAT STATEMENTS +C------------------------------------------------------------------- + 1200 FORMAT(1H0, 98H IVECT IPOTL IEYE IGZRO IGPERT IWAVE IRMAT IWRITE + XIREAD IOC ) + 1300 FORMAT(1H , 9L6,I4) + 1400 FORMAT(1H0, 43H IV IVP IVPP ISHIFT IDIAG ISYM IPERT IALFP ) + 1500 FORMAT(1H ,L3,L4,L5,L7,L6,L5,4L6) + 1600 FORMAT(1H0,21H ALPHA1 ALPHA2 IALPHA/1X,2F7.2,I7) + 1700 FORMAT('0 *** ERROR IN VIVAS. FOR CHANNEL',I3,', REDUCED V-E =', + 1 E13.5/6X,'FOR STEP SIZE',E13.5,', COSH ARGUMENT OF',E13.5, + 2 ' WILL CAUSE OVERFLOW.'/6X,'USE A SMALLER STEP SIZE TO AVOID', + 3 ' THIS ERROR.') + 1800 FORMAT('0 *** WARNING IN VIVAS. INTERVAL SIZE TOO LARGE, SO', + 1 ' CLOSED CHANNEL GROWTH MAY CAUSE NUMERICAL INSTABILITY.'/ + 2 24X,'RNOW =',F8.3,', DRNOW =',F8.3,', G2P(N) =',E13.5) + 1802 FORMAT('0 *** WARNING IN VIVAS. INTERVAL SIZE POSSIBLY TOO', + 1 ' LARGE FOR',I5,' STEPS. INCREASE PRNTLV FOR DETAILS') + 2500 FORMAT(79H0 RMIN RMAX DRNOW DRMAX TOFF TLD + XIAG ) + 2600 FORMAT(F9.5,10F10.5,I10) + 2700 FORMAT(1H ,I5,10E11.4,F6.3,2I5) + 2800 FORMAT(1H ,9D14.7) + 2900 FORMAT(1H0,A10) + 3000 FORMAT('0 VIVAS. R-MATRIX INTEGRATED FROM',F12.4,' TO', + & F12.4,' IN',I6,' STEPS.') + 3100 FORMAT(132H0NTRVL RCENT DRNOW RLAST RNOW DI + XAG(1) DIAG(N) CDIAG COFF SDIAG SOFF ALF + XP NOPN ISTP ) +C----------------***END-VIVAS***------------------------------------- + END + + SUBROUTINE WAVEIG (W, EIGNOW, SCR1, SCR2, RNOW, NCH, + 1 P,MXLAM,VL,IV,RMLMDA,ERED,EINT,CENT,NPOTL) +* THIS SUBROUTINE FIRST SETS UP THE WAVEVECTOR MATRIX AT RNOW +* THEN OBTAINS ITS EIGENVALUES +* WRITTEN BY: MILLARD ALEXANDER +* CURRENT REVISION DATE: 25-SEPT-87 +* ---------------------------------------------------------------- +* VARIABLES IN CALL LIST: +* W: MATRIX OF MAXIMUM ROW DIMENSION NCH USED TO STORE +* WAVEVECTOR MATRIX +* EIGNOW: ON RETURN: ARRAY CONTAINING EIGENVALUES OF WAVEVECTOR M +* SCR1, SCR2: SCRATCH VECTORS OF DIMENSION AT LEAST NCH +* RNOW: VALUE OF INTERPARTICLE SEPARATION AT WHICH WAVEVECTOR MA +* IS TO BE EVALUATED +* NCH: NUMBER OF CHANNELS +* SUBROUTINES CALLED: +* WAVMAT: DETERMINES WAVEVECTOR MATRIX +* F02AAF: NAG ROUTINE TO OBTAIN EIGENVALUES OF REAL, +* SYMMETRIC MATRIX +* DSCAL, DCOPY: LINPACK BLAS ROUTINES +* ---------------------------------------------------------------- + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + INTEGER IERR, NCH, NCHM1, NCHP1 + EXTERNAL DSCAL, DCOPY, WAVMAT, F02AAF +* SQUARE MATRIX (OF ROW DIMENSION NCH) + DIMENSION W(1) +* VECTORS DIMENSIONED AT LEAST NCH + DIMENSION EIGNOW(1), SCR1(1), SCR2(1),P(1),VL(1),IV(1),EINT(1) + DIMENSION CENT(1) +* ------------------------------------------------------------------ + DATA XMIN1 / -1.D0/ + NCHP1 = NCH + 1 + NCHM1 = NCH - 1 + CALL WAVMAT (W, NCH, RNOW, P, VL, IV, ERED, EINT, CENT, RMLMDA, + 1 SCR1, MXLAM, NPOTL) +C +* SINCE WAVMAT RETURNS NEGATIVE OF LOWER TRIANGLE OF W(R) MATRIX (EQ.(3 +* M.H. ALEXANDER, "HYBRID QUANTUM SCATTERING ALGORITHMS ..."), +* NEXT LINE CHANGES ITS SIGN + CALL DSCAL(NCH*NCH, XMIN1, W, 1) +C + IERR=0 + CALL F02AAF(W, NCH, NCH, EIGNOW, SCR1, IERR) + IF (IERR .NE. 0) THEN + WRITE (6, 120) IERR +120 FORMAT(' *** F02AAF IERR =', I3, ' .NE. 0 IN WAVEIG; ABORT ***') + STOP + ENDIF +C + RETURN + END + SUBROUTINE WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG, + 1 MXLAM,NPOTL) +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C EVALUATES THE MATRIX W OF WAVE-VECTORS AT RADIUS R +C W = VCOUPL + EINT + VCENT - ETOT +C ORDER OF THE REAL SYMMETRIC MATRIX W IS N +C THE FULL MATRIX IS COMPUTED +C VL IS THE PREVIOUSLY COMPUTED MATRIX OF THE COUPLING POTENTIAL +C IV IS AN INDEX ARRAY MAPPING P ONTO VL, SUCH THAT VL(I) IS +C A COEFFICIENT TO MULTIPLY P(IV(I)) +C ERED IS THE TOTAL ENERGY ETOT IN REDUCED UNITS +C (ETOT/EPSILON)*(2.*URED*EPSIL*RM**2/HBAR**2) +C EINT(I) IS THE REDUCED INTERNAL ENERGY OF THE I-TH CHANNEL +C CENT(I) IS L*(L+1) FOR THE I-TH CHANNEL +C RMLMDA IS THE SQUARE OF THE RATIO OF RM TO THE DEBROGLIE +C WAVELENGTH AT RELATIVE ENERGY EPSILON +C RMLMDA = 2.*URED*RM**2*EPSIL/HBAR**2 +C RMLMDA MULTIPLIES THE POTENTIAL IN UNITS OF EPSIL +C + DIMENSION W(N,N),VL(1),IV(1),EINT(N),CENT(N),P(MXLAM),DIAG(N) + COMMON/MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C + RSQ=1.D0/(R*R) + IF(IVLFL.LT.0) THEN + NPOT=NPOTL-2 + P(NPOT+1)=RSQ + P(NPOT+2)=1.D0 + ELSE + NPOT=NPOTL + ENDIF +C +C COMPUTE THE RADIAL PARTS OF THE POTENTIAL +C IDUM1 AND IDUM2 ARE DUMMY ARGUMENTS HERE. + CALL POTENL(0,MXLAM,NPOT,IDUM1,R,P,IDUM2) + +C CALL PERTRB(R,P,MXLAM,0) +C + DO 15 I=1,MXLAM + 15 P(I)=RMLMDA*P(I) +C + CALL WAVVEC(VL,P,IV,W,N,NPOTL) +C +C NOW COMPUTE THE DIAGONAL CONTRIBUTIONS W(I,I). +C + DO 18 I=1,N + W(I,I) = W(I,I) - ERED + DIAG(I) = W(I,I) + 18 CONTINUE +C + IF(IVLFL.LT.0) RETURN +C + DO 20 I=1,N + W(I,I) = W(I,I) + EINT(I) + RSQ*CENT(I) + DIAG(I) = W(I,I) +20 CONTINUE + RETURN + END + SUBROUTINE WAVVEC(VL,P,IV,W,N,NPOTL) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION VL(1),P(1),IV(1),W(N,N) +C +C DYNAMIC STORAGE COMMON BLOCK ... + COMMON /MEMORY/ MX,IXNEXT,NIPR,IVLFL,X(1) +C + COMMON/VLSAVE/IVLU +C + IF(IVLFL.GT.0) GOTO 10 +C +C REACH HERE ONLY FOR IVLFL=0: NO IV ARRAY FOR INDEXING +C + IF(IVLU.EQ.0) THEN + I=1 + DO 1 J=1,N + CALL DGEMV('T',NPOTL,J,1.D0,VL(I),NPOTL,P,1,0.D0,W(1,J),1) + 1 I=I+J*NPOTL + ELSE + REWIND IVLU + ISV=IXNEXT + IXNEXT=ISV+N*(N+1)/2 + NUSED=1 + CALL CHKSTR(NUSED) + DO 2 J=1,N + DO 2 K=1,J + 2 W(K,J)=0.D0 + DO 5 LL=1,NPOTL + READ(IVLU) (X(ISV+I),I=0,N*(N+1)/2-1) + I=1 + DO 4 J=1,N + CALL DAXPY(J,P(LL),X(ISV+I-1),1,W(1,J),1) + 4 I=I+J + 5 CONTINUE + IXNEXT=ISV + ENDIF +C +C FILL IN LOWER TRIANGLE +C + CALL DSYFIL('L',N,W,N) + RETURN +C +C ARRIVE HERE FOR NON-TRIVIAL USE OF THE IV ARRAY +C + 10 IF(IVLU.NE.0) THEN + WRITE(6,601) + 601 FORMAT(' *** ERROR IN WAVVEC. IVLU =',I2,' AND IVLFL =',I2/ + 1 ' USE OF THE IV ARRAY IS NOT SUPPORTED FOR IVLU > 0.') + STOP + ENDIF +C + I2=0 + DO 12 J=1,N + DO 12 K=1,J + I1=I2+1 + I2=I2+NPOTL + WW=0.D0 + DO 11 I=I1,I2 + IF(VL(I).NE.0.D0) WW=WW+VL(I)*P(IV(I)) + 11 CONTINUE + W(J,K)=WW + W(K,J)=WW + 12 CONTINUE +C + RETURN + END + SUBROUTINE WKB(N,MXLAM,NPOTL,W,SREAL,SIMAG,P,L,EINT,CENT, + 1 DIAG,NBASIS,WVEC,VL,IV,NUMDER,IPRINT) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C THIS ROUTINE GETS PHASE SHIFT (S-MATRIX) FOR 1-DIMENSIONAL +C SCATTERING EQUATION VIA THE WKB APPROXIMATION USING GAUSS-MEHLER +C NUMERICAL INTEGRATION AS SUGGESTED BY R.T PACK, J. CHEM. PHYS. +C 60, 633 (1974). +C +C THIS ROUTINE IS COMPATIBLE WITH MOLSCAT/IOS CODE +C WRITTEN OCT 1977 BY S. GREEN (GISS), MODIFIED APR 1986 FOR CCP6. +C MODIFIED JUL 86 WITH MORE SOPHISTICATED START (FIND TURNING PT.) +C>>SG MODIFIED SOME OUTPUT FORMATS 5/13/92 +C +C VARIABLES FOR MOLSCAT COMPATIBILITY . . . + LOGICAL NUMDER + DIMENSION W(2),SIMAG(2),SREAL(2),P(2),L(2),EINT(2),CENT(2), + 1 DIAG(2),NBASIS(2),WVEC(2),VL(2),IV(2) +C +C +C THE NUMBER OF GAUSS POINTS IS INCREASED CHECKING FOR CONVERGENCE +C PARAMETERS TO CONTROL GAUSS-MEHLER CONVERGENCE ITERATION. . . + COMMON /WKBCOM/ NGMP(3) +C +C COMMON BLOCK FOR COMMUNICATING WITH COUPLED EQUATION SOLVERS +C + COMMON/DRIVE/DTOL,STEPS,STABIL,CONV,RMIN,RSTOP,XEPS, + 1 DR,DRMAX,RMID,TOLHI,RTURN,VTOL,ESHIFT,ERED,RMLMDA, + 2 NOPEN,JKEEP,ISCRU,MAXSTP +C +C TOLERANCES FOR NEWTON-RAPHSON SEARCH FOR R0 . . . + DATA EPS/5.D-5/ , ITMX/24/ + DATA IDER/1/ +C +C MODIFY CENTRIFUGAL POTENTIAL (CENT) VIA 'LANGER' CORRECTION + PI=ACOS(-1.D0) + DCENT=DBLE(L(1))+.5D0 + DCENT=DCENT*DCENT + CSAVE=CENT(1) + CENT(1)=DCENT +C INITIALIZE OTHER VARIABLES + PI2=2.D0*PI +C +C FIND TURNING POINT VIA NEWTON-RAPHSON METHOD. START WITH RMIN +C + IT=0 + ECNV=EPS*ERED + RCNV=EPS*RMIN + R=RMIN +C IF POTENTIAL IS NOT DECREASING, TRY BACKING UP . . . + 1198 CALL DERMAT(IDER,W,N,R,P,VL,IV,CENT,RMLMDA,MXLAM,NPOTL,NUMDER) + IF (W(1).LE.0.D0) GO TO 1000 + IF (IPRINT.GT.3) WRITE(6,699) IT,R,W(1) + 699 FORMAT('0* * * WKB BAD START. TRY 7/86 FIX. ITER, R, DV/DR =', + 1 I4,2F15.5) + R=0.9D0*R + IT=IT+1 + IF (IT.LE.ITMX) GO TO 1198 + WRITE(6,697) ITMX + 697 FORMAT('0 * * * ERROR (7/86). WKB CANNOT START. ITMX =',I4) + STOP + 1000 CALL WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) + V=W(1) + CALL DERMAT(IDER,W,N,R,P,VL,IV,CENT,RMLMDA,MXLAM,NPOTL,NUMDER) + DVDR=W(1) + DR=-V/DVDR +C TO PREVENT OCCASIONAL ERRATIC BEHAVIOR ALLOW ONLY 25% CHANGE IN R + DRMAX=2.5D-1*ABS(R) + IF (ABS(DR).LE.DRMAX) GO TO 1199 + IF (DR.LT.0.D0) DRMAX=-DRMAX + IF (IPRINT.GT.3) WRITE(6,698) IT,R,DR,DRMAX + 698 FORMAT(' * * WKB. 7/86 FIX. ITER, R, DR, DRMAX =',I4,3F15.5) + DR=DRMAX + 1199 IF (ABS(DR).LE.RCNV.OR.ABS(V).LE.ECNV) GO TO 1009 + IT=IT+1 + R=R+DR + IF (IT.LE.ITMX) GO TO 1000 + IF (IPRINT.GT.3) WRITE(6,694) IT,R,DR,V,DVDR + 694 FORMAT(' WKB: NEWTON-RAPHSON START FAILED TO CONVERGE. IT =',I4 + & /16X,'R,DR,V,DVDR=',4D12.4) +C +C TRY A REGULA-FALSI METHOD. 1ST, UNDO LAST R CHANGE, RESET IT. + R=R-DR + IT=0 + XL=R + YL=V +C STEP IN DIRECTION OF OPPOSITE SIGN FOR POTENTIAL. + IF (V*DVDR*DR.LT.0) GO TO 1201 + DR=-DR + 1201 RSV=R + DO 1202 ITX=1,5 + R=R+DR + CALL WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) + V=W(1) + IF (V*YL.LT.0.D0) GO TO 1205 + 1202 CONTINUE + DR=-DR + R=RSV + DO 1203 ITX=1,5 + R=R+DR + CALL WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) + V=W(1) + IF (V*YL.LT.0.D0) GO TO 1205 + 1203 CONTINUE + WRITE(6,620) + 620 FORMAT('0 WKB. * * * CRASH IN REGULA-FALSI. GIVING UP.') + STOP + 1205 XR=R + YR=V + 1210 SLOPE=(YR-YL)/(XR-XL) + XINT=YL-SLOPE*XL + XNEW=-XINT/SLOPE + CALL WAVMAT(W,N,XNEW,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM, + 1 NPOTL) + YNEW=W(1) + IT=IT+1 + IF (ABS(YNEW).GT.ECNV) GO TO 1211 + 1215 DR=XR-XL + IF (IPRINT.GT.3) WRITE(6,621) IT,XNEW,DR,YNEW + 621 FORMAT(' WKB: REGULA-FALSI CONVERGED. IT,R,DR,V =',I4,3F10.4) + R=XNEW + GO TO 1009 + 1211 IF (YNEW*YR.GT.0.D0) GO TO 1212 + IF (YNEW*YL.GT.0.D0) GO TO 1213 + WRITE(6,622) XL,XNEW,XR,YL,YNEW,YR + 622 FORMAT('0 WKB. IMPOSSIBLE X(L,NEW,R) AND Y(L,NEW,R)=',6D12.4) + STOP + 1212 YR=YNEW + XR=XNEW + GO TO 1220 + 1213 YL=YNEW + XL=XNEW + 1220 IF (ABS(XR-XL).LE.RCNV) GO TO 1215 +C ALLOW FOR TWICE AS MANY ITERATIONS AS NEWTON-RAPHSON. + IF (IT.LT.2*ITMX) GO TO 1210 + WRITE(6,623) IT,XL,XNEW,XR,YL,YNEW,YR + 623 FORMAT(' WKB: REGULA-FALSI START FAILED TO CONVERGE. IT=',I4/ + 1 16X, 'X(L,NEW,R) AND Y(L,NEW,R)=',6D12.4) +C STOP +C +C GET WKB PHASE SHIFT BY PACK'S GAUSS-MEHLER QUADRATURE +C +C FORCE NGMP TO REASONABLE VALUES IF NECESSARY. + 1009 NSTART=MAX0(NGMP(1),3) + NADD=MAX0(NGMP(2),1) + NHI=MAX0(NGMP(3),NSTART+3*NADD) + RMIN=R + DR0=R + DWVEC=WVEC(1) + XKR=DWVEC*DR0 + DO 2000 NPOINT=NSTART,NHI,NADD + NPSV=NPOINT + X2NP1=DBLE(2*NPOINT+1) + SUM=0.D0 + XJ=0.D0 + DO 2100 J=1,NPOINT + XJ=XJ+1.D0 + X=COS(XJ*PI/X2NP1) + X2=X*X + WT=(1.D0-X2)*PI/X2NP1 + XCOMP=SQRT(1.D0-X2) + R=DR0/X + CALL WAVMAT(W,N,R,P,VL,IV,ERED,EINT,CENT,RMLMDA,DIAG,MXLAM,NPOTL) +C WAVMAT GIVES NEGATIVE OF WHAT WE WANT + W(1)=-W(1) +C GUARD AGAINST SQAURE ROOTS OF NEGATIVE DW + IF (W(1).GE.0.D0) GO TO 2109 +C JUDGE AS ROUND-OFF ERROR IF ABS(W) LE. 0.001*ERED + IF (ABS(W(1)).LE.1.D-3*ERED) GO TO 2108 + WRITE(6,696) R,W(1) + 696 FORMAT(' * * * ERROR. WKB IN CLASSICALLY FORBIDDEN REGION. R, W + & =',2E16.6) + 2108 W(1)=0.D0 + 2109 DW=W(1) + F=(SQRT(DW)/(DWVEC*XCOMP)-1.D0)/X2 + 2100 SUM=SUM+WT*F + ETA=XKR*SUM+(SQRT(DCENT)-XKR)*PI*.5D0 + IF (NPOINT.GT.NSTART) GO TO 2200 +C ON FIRST ITERATION, GET SET FOR CONVERGENCE TEST. +C SUBTRACT OUT AN INTEGRAL NUMBER OF 2*PI TO NORMALIZE + NPI=ETA/PI2 + IF (ETA.LT.0.D0) NPI=NPI-1 + PIMIN=DBLE(NPI)*PI2 + ETA=ETA-PIMIN + ETAOLD=ETA + GO TO 2000 +C TEST FOR CONVERGENCE + 2200 ETA=ETA-PIMIN + X2=ABS(ETA-ETAOLD) + IF (X2.LE.DTOL) GO TO 2900 + X=ETAOLD + ETAOLD=ETA + 2000 CONTINUE +C NOT CONVERGED IF THIS POINT IS REACHED. . . + NPOINT=NPSV + NM1=NPOINT-NADD + WRITE(6,695) NPI,DTOL, NM1,X, NPOINT,ETA + 695 FORMAT('0 * * * WARNING. NO CONVERGENCE OF GAUSS-MEHLER INTEGRATI + &ON. NPI =',I4,' STEST =',D12.4/ + A (15X,'FOR',I4,' GAUSS POINTS, ETA-NPI*(2*PI) =',F12.7) ) +C SET CONVERGENCE FLAG, IF CONVERGENCE IS REALLY POOR + IF (X2.GT.5.D0*DTOL) CONV=-1.D0 + 2900 IF (IPRINT.GE.3) WRITE(6,612) NPSV,X2,DR0,NPI,ETA + 612 FORMAT('0 * * * NOTE. WKB PHASE SHIFT BY',I4,'-POINT QUAD, TOL =' + & ,D12.4,', R0 =',F8.4,', ETA IS',I5,'*(2*PI) +',F9.5) +C +C CONVERT PHASE SHIFT TO SREAL, SIMAAG / RESTORE FOR RETURN + SREAL(1)=COS(2.D0*ETA) + SIMAG(1)=SIN(2.D0*ETA) + CENT(1)=CSAVE + RETURN +C + END + FUNCTION XNINEJ(IX1,IY1,IZ1,IX2,IY2,IZ2,IX3,IY3,IZ3) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION XJ9J(200) + DATA MXDIM/200/ +C + IVAL=MXDIM + CALL J9J(DBLE(IX1),DBLE(IY1), + 1 DBLE(IX2),DBLE(IY2),DBLE(IZ2), + 2 DBLE(IX3),DBLE(IY3),DBLE(IZ3), + 3 IVAL,Z1MIN,XJ9J) + IND=1+IZ1-INT(Z1MIN+0.1D0) + XNINEJ=0.D0 + IF(IND.GE.1 .AND. IND.LE.IVAL) XNINEJ=XJ9J(IND) + RETURN + END + FUNCTION YRR(L1,L2,L,CT1,CT2,DP) +C +C BISPHERICAL HARMONIC ANGULAR FUNCTIONS FOR TWO DIATOMS +C CT1, CT2 ARE COS(THETA-1) AND COS(THETA-2), AND +C DP IS DELTA(PHI), I.E., PHI2-PHI1, IN RADIANS +C CF. GREEN, JCP 62, 2271 (1975) APPENDIX. +C N.B. P(L,M;X) THERE IS (2*PI)**-1/2 NORMALIZED P(L,M;X) +C MOLSCAT PLM(L,M,CT) ROUTINE IS NORMALIZED ON CT, AND +C PLM(L,0,1.D0)=SQRT((2L+1)/2) . +C THUS, MUST MULT EACH PLM BY (2*PI)**-1/2 +C +C ODD L1+L2+L *NOT* ALLOWED; TRAPPED W/MESSAGE AND STOP +C +C NEEDS ROUTINES THRJ(XJ1,XJ2,XJ3,XM1,XM2,XM3) +C PLM(L,M,COSTH) +C PARITY3(J) +C + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + LOGICAL ODD + DATA PI/3.14159 26535 89793 D0/ + ODD(I)=2*(I/2)-I.NE.0 +C + IF (ODD(L1+L2+L)) GO TO 9999 +C + XL1=L1 + XL2=L2 + XL=L +C SQRT(4*PI) FROM Y(L,M,THETA=0), 2*PI FOR TWO PLM'S + DEN=SQRT(4.D0*PI)*2.D0*PI + FACT=((2.D0*XL+1.D0)/DEN)*PARITY3(L1+L2) + MTOP=MIN(L1,L2) + M=0 + XM=0.D0 + SUM=THRJ(XL1,XL2,XL,0.D0,0.D0,0.D0)*PLM(L1,0,CT1)*PLM(L2,0,CT2) + 2000 M=M+1 + IF (M.GT.MTOP) GO TO 3000 + XM=XM+1.D0 + SUM=SUM+2.D0*PARITY3(M)*THRJ(XL1,XL2,XL,XM,-XM,0.D0)* + 1 PLM(L1,M,CT1)*PLM(L2,M,CT2)*COS(XM*DP) + GO TO 2000 + 3000 YRR=FACT*SUM + RETURN + 9999 WRITE(6,699) L1,L2,L + 699 FORMAT('0 YRR *** ERROR. ODD ARGUMENTS NOT ALLOWED',3I5) + STOP + END + SUBROUTINE YTOK(NB,WVEC,L,N,NOPEN,SJ,SJP,SN,SNP,Y,T,Q,RUP) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) +C +C ROUTINE TO OBTAIN THE K MATRIX FROM THE LOG DERIVATIVE MATRIX +C ON ENTRY, Y HOLDS THE LOG DERIVATIVE MATRIX +C ON EXIT, Q HOLDS THE K MATRIX +C SEE: B.R.JOHNSON, JOURNAL OF COMPUTATIONAL PHYSICS 13, 445 (1973) +C + DIMENSION NB(N), WVEC(N), L(N), SJ(N), SJP(N), SN(N), SNP(N), + 1 Y(1), T(1), Q(1) +C + IF(NOPEN.EQ.0) RETURN + DO 10 I = 1,NOPEN + NX = NB(I) + DW = WVEC(NX) + DARG = DW*RUP + CALL RBES(L(NX), DARG, UJ, UJP, UN, UNP) + ROOTDW = SQRT(DW) + SJ(NX) = UJ/ROOTDW + SJP(NX) = UJP*ROOTDW + SN(NX) = UN/ROOTDW + SNP(NX) = UNP*ROOTDW + 10 CONTINUE + IF (NOPEN.EQ.N) GO TO 30 + NCLOSE = N - NOPEN + DO 20 I = 1,NCLOSE + J = NOPEN + I + NX = NB(J) + DW = ABS(WVEC(NX)) + DARG = DW*RUP + CALL RMSBF(L(NX), DARG, RATIO) + SN(NX) = 1.D0 + SNP(NX) = RATIO*DW + 20 CONTINUE + 30 CONTINUE +C + CALL DSYFIL('U',N,Y,N) +C + IND = 0 + DO 40 J = 1,NOPEN + NXJ = NB(J) + NXJJ = (NXJ - 1)*N + DO 40 I = 1,N + IND = IND + 1 + INDY = NXJJ + NB(I) + T(IND) = Y(INDY)*SJ(NXJ) + 40 CONTINUE +C + IND = - N + DO 50 I = 1,NOPEN + IND = IND + N + 1 + T(IND) = T(IND) - SJP(NB(I)) + 50 CONTINUE +C + IND = 0 + DO 60 J = 1,N + NXJ = NB(J) + NXJJ = (NXJ - 1)*N + DO 60 I = 1,N + IND = IND + 1 + INDY = NXJJ + NB(I) + Q(IND) = Y(INDY)*SN(NXJ) + 60 CONTINUE +C + IND = - N + DO 70 I = 1,N + IND = IND + N + 1 + Q(IND) = Q(IND) - SNP(NB(I)) + 70 CONTINUE +C + CALL DGESV(N,NOPEN,Q,N,SJ,T,N,IER) + IF (IER.NE.0) GO TO 900 +C + IND = 0 + DO 80 J = 1,NOPEN + INDA = (J - 1)*N + DO 80 I = 1,NOPEN + IND = IND + 1 + INDA = INDA + 1 + Q(IND) = T(INDA) + 80 CONTINUE +C +C Q NOW HOLDS THE K MATRIX. FORCE SYMMETRY ON IT. +C + CALL KSYM(Q, NOPEN) + RETURN +C + 900 WRITE (6,901) IER + 901 FORMAT('0***** ERROR IN LINEAR EQUATION SOLVER IN YTOK.', + 1 ' IER =',I4,'. RUN HALTED.') + STOP + END + FUNCTION ZBES(K) +C *** ROUTINE REQUIRED BY GASLEG (GAUSS LEGENDRE PT/WT GENERATOR) +C *** TAKEN FROM AD VAN DER AVOIRD'S N2-N2 CODE (SG 11/7/91) + DOUBLE PRECISION PI,ZBES,B,BB,B3,B5,B7 + DATA PI/3.14159 26535 89793 D0/ + B=(DBLE(K)-0.25D0)*PI + BB=1.0D0/(8.0D0*B) + B3=BB*BB*BB + B5=B3*BB*BB + B7=B5*BB*BB + ZBES=B+BB-(124.0D0/3.0D0)*B3+(120928.0D0/15.0D0)*B5-(401743168.0D0 + 1/105.0D0)*B7 + RETURN + END diff --git a/vrtp_co_co2.f b/vrtp_co_co2.f new file mode 100644 index 0000000..d5f9cfd --- /dev/null +++ b/vrtp_co_co2.f @@ -0,0 +1,68 @@ + SUBROUTINE VRTP(IDERIV,R,P) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + DIMENSION P(1) +C +C ***************************************************************** +C * IF POTENTIAL IS --NOT-- EXPANDED IN ANGULAR FUNCTIONS, I.E., * +C * MXSYM.LE.0, THIS ROUTINE MUST SUPPLY THE POTENTIAL AND * +C * ITS 1ST AND 2ND DERIVATIVE (IDERIV=0,1,2, RESPECTIVELY). * +C * EVALUATE POTENTIAL AT ANGLES SPECIFIED IN COMMON /ANGLES/ * +C * ITYPE=1: COSANG(1) IS THETA * +C * ITYPE=2: COSANG(1) IS THETA, COSANG(2) IS VIB COORD * +C * ITYPE=3: COSANG(1),COSANG(2) ARE THETAS, COSANG(3) IS PHI * +C * SINCE IHOMO/ICNSYM CANNOT BE DETERMINED BY IOSBGP WITHOUT * +C * ANGULAR TERMS, THEY MAY BE READ IN &POTL OR SET HERE IN * +C * /ANGLES/. VALUES SET HERE OVERRIDE &POTL INPUT. * +C * IF NOT SET, DEFAULT VALUES WILL BE IHOMO=ICNSYM=1 * +C * POTENTIAL, RETURNED IN P(1), MUST BE MULTIPLIED BY 'FACTOR' * +C * (SET IN IOSBIN AND PASSED IN /ANGLES/) TO COUNTER LOWEST * +C * ANGULAR FUNCTION (ITYPE DEPENDENT) WHICH MULTIPLIES IT. * +C * INITIALIZATION CALL (IDERIV.LT.0) MAY SET AND/OR USE * +C * RM=R AND EPSIL=P(1) * +C ***************************************************************** +C + COMMON /ANGLES/COSANG(7),FACTOR,IHOMO,ICNSYM,IHOMO2,ICNSY2 +C + IF (IDERIV.LT.0) THEN + IHOMO=2 + IHOMO2=1 + WRITE(6,*) ' This is the CO2 - CO PES ' +c + RETURN + ENDIF + IF (IDERIV.GT.1) STOP +C + P(1)=(POTFUN(R,COSANG(1),COSANG(2),COSANG(3)))*FACTOR + + WRITE(2,101) R,COSANG(1),COSANG(2),COSANG(3),P(1) + 101 format(5f12.4) + + + RETURN + END +C--------------------------------------------------- + + FUNCTION POTFUN(R,T1,T2,PHI) + IMPLICIT DOUBLE PRECISION (A-H,O-Z) + COMMON /ANGLES/COSANG(7),FACTOR,IHOMO,ICNSYM,IHOMO2,ICNSY2 + !dimension xi(4) + character (len=40) :: NAME1 + real*8 :: xi(4),V,pii,th1,th2,phi,ang2boh + !real*8 r,t1,t2,phi,v,ang2boh + ang2boh=1.889726d0 + pii = dacos(-1d0) + + NAME1='PES-CO2-CO-2892' + xi(1)=R/ang2boh + !xi(1)=r + xi(2)=COSANG(1) + xi(3)=COSANG(2) + xi(4)=COSANG(3) + !xi(2)=dcos(th1*pii/180.d0) + !xi(3)=dcos(th2*pii/180.d0) + xi(4)=xi(4)*(180.d0/pii) + call PES(xi, V, NAME1, 0, 0) + POTFUN=V + RETURN + END +