LOSALAMOS_OMCODE.FOR
******************** subroutine omin ***************************
subroutine omin(ki,ieof)
c
c routine to read optical model parameters in parameter lib
c
parameter (ndim1=10, ndim2=11, ndim3=20, ndim4=30, ndim5=10,
1 ndim6=10,ndim7=120)
character*1 author,refer,summary
common/lib/author(80),refer(80),summary(320),iref,emin,emax,
1 izmin,izmax,iamin,iamax,imodel,jrange(5),epot(5,ndim1),
2 rco(5,ndim1,ndim2),aco(5,ndim1,ndim2),pot(5,ndim1,ndim3),
3 ncoll(ndim4),nvib(ndim4),nisotop,iz(ndim4),ia(ndim4),
4 lmax(ndim4),bandk(ndim4),def(ndim4,ndim5),idef(ndim4),
5 izproj,iaproj,exv(ndim7,ndim4),iparv(ndim7,ndim4),
6 nph(ndim7,ndim4),defv(ndim7,ndim4),thetm(ndim7,ndim4),
7 beta0(ndim4),gamma0(ndim4),xmubeta(ndim4),ex(ndim6,ndim4),
8 spin(ndim6,ndim4),ipar(ndim6,ndim4),spinv(ndim7,ndim4),
9 jcoul,ecoul(ndim1),rcoul(ndim1),rcoul0(ndim1),beta(ndim1)
c
1 format(80a1)
c
ieof=0
read(ki,*,end=999) iref
read(ki,1) (author(i),i=1,80)
read(ki,1) (refer(i),i=1,80)
read(ki,1) (summary(i),i=1,320)
read(ki,*) emin,emax
read(ki,*) izmin,izmax
read(ki,*) iamin,iamax
read(ki,*) imodel,izproj,iaproj
c
do 100 i=1,5
read(ki,*) jrange(i)
if(jrange(i).eq.0) go to 100
krange=iabs(jrange(i))
do 98 j=1,krange
read(ki,*) epot(i,j)
read(ki,*) (rco(i,j,n),n=1,ndim2)
read(ki,*) (aco(i,j,n),n=1,ndim2)
read(ki,*) (pot(i,j,n),n=1,ndim3)
98 continue
100 continue
read(ki,*) jcoul
if(jcoul.le.0) go to 110
do 108 j=1,jcoul
108 read(ki,*) ecoul(j),rcoul(j),rcoul0(j),beta(j)
110 if(imodel.ne.1) go to 130
read(ki,*) nisotop
do 120 n=1,nisotop
read(ki,*) iz(n),ia(n),ncoll(n),lmax(n),idef(n),bandk(n),
1 (def(n,k),k=2,idef(n),2)
do 124 k=1,ncoll(n)
read(ki,*) ex(k,n),spin(k,n),ipar(k,n)
124 continue
120 continue
go to 200
130 if(imodel.ne.2) go to 150
read(ki,*) nisotop
do 140 n=1,nisotop
read(ki,*) iz(n),ia(n),nvib(n)
do 138 k=1,nvib(n)
read(ki,*) exv(k,n),spinv(k,n),iparv(k,n),nph(k,n),defv(k,n),
1 thetm(k,n)
138 continue
140 continue
go to 200
150 if(imodel.ne.3)go to 200
read(ki,*) nisotop
do 160 n=1,nisotop
read(ki,*) iz(n),ia(n),beta0(n),gamma0(n),xmubeta(n)
160 continue
200 continue
read(ki,1,end=999) idum
return
999 ieof=1
return
end
****************** subroutine omout ******************************
subroutine omout(ko)
c
c routine to write optical model parameters in parameter lib
c
parameter (ndim1=10, ndim2=11, ndim3=20, ndim4=30, ndim5=10,
1 ndim6=10,ndim7=120)
character*1 author,refer,summary
common/lib/author(80),refer(80),summary(320),iref,emin,emax,
1 izmin,izmax,iamin,iamax,imodel,jrange(5),epot(5,ndim1),
2 rco(5,ndim1,ndim2),aco(5,ndim1,ndim2),pot(5,ndim1,ndim3),
3 ncoll(ndim4),nvib(ndim4),nisotop,iz(ndim4),ia(ndim4),
4 lmax(ndim4),bandk(ndim4),def(ndim4,ndim5),idef(ndim4),
5 izproj,iaproj,exv(ndim7,ndim4),iparv(ndim7,ndim4),
6 nph(ndim7,ndim4),defv(ndim7,ndim4),thetm(ndim7,ndim4),
7 beta0(ndim4),gamma0(ndim4),xmubeta(ndim4),ex(ndim6,ndim4),
8 spin(ndim6,ndim4),ipar(ndim6,ndim4),spinv(ndim7,ndim4),
9 jcoul,ecoul(ndim1),rcoul(ndim1),rcoul0(ndim1),beta(ndim1)
dimension rdum(ndim2),adum(ndim2),pdum(ndim3)
c
1 format(10i5)
2 format(10a8)
4 format(4f10.3)
5 format(f12.5,(5(1x,1pe11.4)),/12x,(5(1x,1pe11.4)))
6 format(5i5,f5.1,(4(1x,1pe10.3)),/30x,(4(1x,1pe10.3)))
7 format(f12.8,f7.1,2i4,1p,2(1x,e11.4))
8 format(2i5,1p,3(1x,e11.4))
9 format(80a1)
c
data ldum/8h++++++++/
c
write(ko,1) iref
write(ko,9) author
write(ko,9) refer
write(ko,9) summary
write(ko,4) emin,emax
write(ko,1) izmin,izmax
write(ko,1) iamin,iamax
write(ko,1) imodel,izproj,iaproj
do 100 i=1,5
write(ko,1) jrange(i)
if(jrange(i).eq.0) go to 100
krange=iabs(jrange(i))
do 98 j=1,krange
write(ko,4) epot(i,j)
c write(ko,5) (rco(i,j,n),n=1,ndim2)
c write(ko,5) (aco(i,j,n),n=1,ndim2)
c write(ko,5) (pot(i,j,n),n=1,ndim3)
do 82 n=1,ndim2
rdum(n)=rco(i,j,n)
82 adum(n)=aco(i,j,n)
do 84 n=1,ndim3
84 pdum(n)=pot(i,j,n)
call linew3(rdum,ndim2,ko)
call linew3(adum,ndim2,ko)
call linew3(pdum,ndim3,ko)
98 continue
100 continue
write(ko,1)jcoul
if(jcoul.le.0) go to 110
do 108 j=1,jcoul
108 write(ko,4)ecoul(j),rcoul(j),rcoul0(j),beta(j)
110 if(imodel.ne.1) go to 130
write(ko,1) nisotop
do 120 n=1,nisotop
write(ko,6) iz(n),ia(n),ncoll(n),lmax(n),idef(n),bandk(n),
1 (def(n,k),k=2,idef(n),2)
do 124 k=1,ncoll(n)
write(ko,7) ex(k,n),spin(k,n),ipar(k,n)
124 continue
120 continue
go to 200
130 if(imodel.ne.2) go to 150
write(ko,1) nisotop
do 140 n=1,nisotop
write(ko,1) iz(n),ia(n),nvib(n)
do 138 k=1,nvib(n)
write(ko,7) exv(k,n),spinv(k,n),iparv(k,n),nph(k,n),defv(k,n),
1 thetm(k,n)
138 continue
140 continue
go to 200
150 if(imodel.ne.3)go to 200
write(ko,1) nisotop
do 160 n=1,nisotop
write(ko,8) iz(n),ia(n),beta0(n),gamma0(n),xmubeta(n)
160 continue
200 continue
write(ko,2)(ldum,l=1,10)
return
end
subroutine linew3(ah,nah,ko)
c
c utility for omout RIPL single line writes
c requires subroutine cxfp
c
dimension ah(25),f(25),is(25),j(25)
character*8 start1(2),start2(2),fmt(15),f8(2),f7(2),finish
data start1/'(f12.5, ','1x '/
data start2/'(13x, ',' '/
data f8/',f8.5, ','a1,i1,1x'/
data f7/',f7.4, ','a1,i2,1x'/
data finish/')'/
c
c Write first line
c
l=0
do 110 k=1,2
l=l+1
fmt(l)=start1(k)
110 continue
do 120 k=2,7
call cxfp(ah(k),f(k),is(k),j(k))
l=l+1
if(iabs(j(k)).ge.10)go to 115
fmt(l)=f8(1)
l=l+1
fmt(l)=f8(2)
go to 120
115 fmt(l)=f7(1)
l=l+1
fmt(l)=f7(2)
120 continue
l=l+1
fmt(l)=finish
write(ko,fmt)ah(1),(f(k),is(k),j(k),k=2,7)
c
c Write remaining full lines
c
nleft=nah-7
nloop=nleft/6
nremain=nleft-nloop*6
nold=1
if(nloop.le.0)go to 165
do 160 nlp=1,nloop
nold=nold+6
l=0
do 140 k=1,2
l=l+1
fmt(l)=start2(k)
140 continue
do 150 k=1,6
call cxfp(ah(k+nold),f(k),is(k),j(k))
l=l+1
if(iabs(j(k)).ge.10)go to 145
fmt(l)=f8(1)
l=l+1
fmt(l)=f8(2)
go to 150
145 fmt(l)=f7(1)
l=l+1
fmt(l)=f7(2)
150 continue
l=l+1
fmt(l)=finish
write(ko,fmt)(f(k),is(k),j(k),k=1,6)
160 continue
165 if(nremain.le.0) go to 200
c
c Write remaining partial line
c
nold=nold+6
l=0
do 170 k=1,2
l=l+1
fmt(l)=start2(k)
170 continue
do 180 k=1,nremain
call cxfp(ah(k+nold),f(k),is(k),j(k))
l=l+1
if(iabs(j(k)).ge.10)go to 175
fmt(l)=f8(1)
l=l+1
fmt(l)=f8(2)
go to 180
175 fmt(l)=f7(1)
l=l+1
fmt(l)=f7(2)
180 continue
l=l+1
fmt(l)=finish
write(ko,fmt)(f(k),is(k),j(k),k=1,nremain)
200 return
end
subroutine cxfp (x,f,s,n)
c ******************************************************************
c convert x for punching.
c x - floating point number = f*10.0**n
c f - 0.99995 le f lt 9.999995
c s sign (hollerith + or -) of exponent
c n - exponent
c ******************************************************************
cibm
c real*8 xx,ff
cibm
data sp/1h+/,sm/1h-/
if (x.ne.0.0) go to 100
f=0.0
s=sp
n=0
return
ccdc
100 n=alog10(abs(x))
if (abs(x).lt.1.0) go to 140
f=x/10.0**n
s=sp
if (iabs(n).lt.10.and.abs(f).lt.9.9999995) go to 170
if (iabs(n).ge.10.and.abs(f).lt.9.999995) go to 170
f=f/10.0
n=n+1
go to 170
140 n=1-n
f=x*10.0**n
s=sm
if (iabs(n).lt.10.and.abs(f).lt.9.9999995) go to 170
if (iabs(n).ge.10.and.abs(f).lt.9.999995) go to 170
f=f/10.0
n=n-1
if (n.gt.0) go to 170
s=sp
170 continue
ccdc
cibm
c 100 xx=x
c n=dlog10(dabs(xx))
c if (dabs(xx).lt.1.0d0) go to 140
c ff=xx/10.d0**n
c s=sp
c if (iabs(n).lt.10.and.dabs(ff).lt.9.9999995d0) go to 170
c if (iabs(n).ge.10.and.dabs(ff).lt.9.999995d0) go to 170
c ff=ff/10.0d0
c n=n+1
c go to 170
c 140 n=1-n
c ff=xx*10.0d0**n
c s=sm
c if (iabs(n).lt.10.and.dabs(ff).lt.9.9999995d0) go to 170
c if (iabs(n).ge.10.and.dabs(ff).lt.9.999995d0) go to 170
c ff=ff/10.0d0
c n=n-1
c if (n.gt.0) go to 170
c s=sp
c 170 f=ff
cibm
return
end
********************* omsumry code **********************
program omsumry
c
c P.G.Young, Group T-2, Los Alamos National Laboratory
c Mail Stop B243, email address pgy@lanl.gov
c
c Code to summarize data in RIPL data file
c
parameter (ndim1=10, ndim2=11, ndim3=20, ndim4=30, ndim5=10,
1 ndim6=10,ndim7=120)
character*1 author,refer,summary
common/lib/iref,author(80),refer(80),summary(320),emin,emax,
1 izmin,izmax,iamin,iamax,imodel,jrange(5),epot(5,ndim1),
2 rco(5,ndim1,ndim2),aco(5,ndim1,ndim2),pot(5,ndim1,ndim3),
3 ncoll(ndim4),nvib(ndim4),nisotop,iz(ndim4),ia(ndim4),
4 lmax(ndim4),bandk(ndim4),def(ndim4,ndim5),idef(ndim4),
5 izproj,iaproj,exv(ndim7,ndim4),iparv(ndim7,ndim4),
6 nph(ndim7,ndim4),defv(ndim7,ndim4),thetm(ndim7,ndim4),
7 beta0(ndim4),gamma0(ndim4),xmubeta(ndim4),ex(ndim6,ndim4),
8 spin(ndim6,ndim4),ipar(ndim6,ndim4),spinv(ndim7,ndim4),
9 jcoul,ecoul(ndim1),rcoul(ndim1),rcoul0(ndim1),beta(ndim1)
c
c call qstart
c
open(unit=1,file='tape1',status='unknown')
open(unit=6,file='tape6',status='unknown')
c
c call filerep
c
ki=1
ko=6
c
ict=0
100 call omin(ki,ieof)
if(ieof.gt.0) go to 999
ict=ict+1
call sumprt(ko)
go to 100
999 continue
write(*,*)'Number of entries =',ict
write(ko,*)' '
write(ko,*)' '
write(ko,*)'Number of entries =',ict
stop
end
subroutine omin(ki,ieof)
c
c Routine to print summary information from RIPL file
c
parameter (ndim1=10, ndim2=11, ndim3=20, ndim4=30, ndim5=10,
1 ndim6=10,ndim7=120)
character*1 author,refer,summary
common/lib/iref,author(80),refer(80),summary(320),emin,emax,
1 izmin,izmax,iamin,iamax,imodel,jrange(5),epot(5,ndim1),
2 rco(5,ndim1,ndim2),aco(5,ndim1,ndim2),pot(5,ndim1,ndim3),
3 ncoll(ndim4),nvib(ndim4),nisotop,iz(ndim4),ia(ndim4),
4 lmax(ndim4),bandk(ndim4),def(ndim4,ndim5),idef(ndim4),
5 izproj,iaproj,exv(ndim7,ndim4),iparv(ndim7,ndim4),
6 nph(ndim7,ndim4),defv(ndim7,ndim4),thetm(ndim7,ndim4),
7 beta0(ndim4),gamma0(ndim4),xmubeta(ndim4),ex(ndim6,ndim4),
8 spin(ndim6,ndim4),ipar(ndim6,ndim4),spinv(ndim7,ndim4),
9 jcoul,ecoul(ndim1),rcoul(ndim1),rcoul0(ndim1),beta(ndim1)
c
1 format(80a1)
c
ieof=0
read(ki,*,end=999) iref
read(ki,1) (author(i),i=1,80)
read(ki,1) (refer(i),i=1,80)
read(ki,1) (summary(i),i=1,320)
read(ki,*) emin,emax
read(ki,*) izmin,izmax
read(ki,*) iamin,iamax
read(ki,*) imodel,izproj,iaproj
c
do 100 i=1,5
read(ki,*) jrange(i)
if(jrange(i).eq.0) go to 100
krange=iabs(jrange(i))
do 98 j=1,krange
read(ki,*) epot(i,j)
read(ki,*) (rco(i,j,n),n=1,ndim2)
read(ki,*) (aco(i,j,n),n=1,ndim2)
read(ki,*) (pot(i,j,n),n=1,ndim3)
98 continue
100 continue
read(ki,*) jcoul
if(jcoul.le.0) go to 110
do 108 j=1,jcoul
108 read(ki,*) ecoul(j),rcoul(j),rcoul0(j),beta(j)
110 if(imodel.ne.1) go to 130
read(ki,*) nisotop
do 120 n=1,nisotop
read(ki,*) iz(n),ia(n),ncoll(n),lmax(n),idef(n),bandk(n),
1 (def(n,k),k=2,idef(n),2)
do 124 k=1,ncoll(n)
read(ki,*) ex(k,n),spin(k,n),ipar(k,n)
124 continue
120 continue
go to 200
130 if(imodel.ne.2) go to 150
read(ki,*) nisotop
do 140 n=1,nisotop
read(ki,*) iz(n),ia(n),nvib(n)
do 138 k=1,nvib(n)
read(ki,*) exv(k,n),spinv(k,n),iparv(k,n),nph(k,n),defv(k,n),
1 thetm(k,n)
138 continue
140 continue
go to 200
150 if(imodel.ne.3)go to 200
read(ki,*) nisotop
do 160 n=1,nisotop
read(ki,*) iz(n),ia(n),beta0(n),gamma0(n),xmubeta(n)
160 continue
200 continue
read(ki,1,end=999) idum
return
999 ieof=1
return
end
subroutine sumprt(ko)
c
c routine to print summary information from RIPL formatted library
c
parameter (ndim1=10, ndim2=11, ndim3=20, ndim4=30, ndim5=10,
1 ndim6=10,ndim7=120)
character*1 author,refer,summary
character*8 ldum,proj
character*40 model
character*20 area
common/lib/iref,author(80),refer(80),summary(320),emin,emax,
1 izmin,izmax,iamin,iamax,imodel,jrange(5),epot(5,ndim1),
2 rco(5,ndim1,ndim2),aco(5,ndim1,ndim2),pot(5,ndim1,ndim3),
3 ncoll(ndim4),nvib(ndim4),nisotop,iz(ndim4),ia(ndim4),
4 lmax(ndim4),bandk(ndim4),def(ndim4,ndim5),idef(ndim4),
5 izproj,iaproj,exv(ndim7,ndim4),iparv(ndim7,ndim4),
6 nph(ndim7,ndim4),defv(ndim7,ndim4),thetm(ndim7,ndim4),
7 beta0(ndim4),gamma0(ndim4),xmubeta(ndim4),ex(ndim6,ndim4),
8 spin(ndim6,ndim4),ipar(ndim6,ndim4),spinv(ndim7,ndim4),
9 jcoul,ecoul(ndim1),rcoul(ndim1),rcoul0(ndim1),beta(ndim1)
c
1 format(' IREF=',i5,2x,a8,' incident, ',a40)
2 format(' Author(s)= ',60a1,/12x,20a1)
3 format(' Reference= ',60a1,/12x,20a1)
4 format(' Summary= ',60a1,/12x,60a1,/12x,60a1,/12x,60a1,/12x,
1 60a1,/12x,20a1)
5 format(' Z-Range=',i3,'-',i2,' A-Range=',i4,'-',i3,' E-Range=',
1 i4,'-',i3,' MeV')
6 format(10a8)
c
data ldum/'++++++++'/
c
if(izproj.eq.0.and.iaproj.eq.1) proj=' Neutron'
if(izproj.eq.1.and.iaproj.eq.1) proj=' Proton'
if(izproj.eq.1.and.iaproj.eq.2) proj='Deuteron'
if(izproj.eq.1.and.iaproj.eq.3) proj=' Triton'
if(izproj.eq.2.and.iaproj.eq.3) proj=' He-3'
if(izproj.eq.2.and.iaproj.eq.4) proj=' Alpha'
if(imodel.eq.0)model='spherical nucleus model'
if(imodel.eq.1)model='coupled-channels rotational model'
if(imodel.eq.2)model='vibrational model'
if(imodel.eq.3)model='non=axial deformed model'
iarea=mod(iref,1000)
if(iarea.le.99) area='United States (LANL)'
if(iarea.ge.100.and.iarea.le.199)area='United States'
if(iarea.ge.200.and.iarea.le.299)area='Japan'
if(iarea.ge.300.and.iarea.le.399)area='Russia'
if(iarea.ge.400.and.iarea.le.499)area='Europe'
if(iarea.ge.500.and.iarea.le.599)area='China'
if(iarea.ge.600.and.iarea.le.649)area='FSU'
if(iarea.ge.650.and.iarea.le.699)area='India, Pakistan'
if(iarea.ge.700.and.iarea.le.799)area='Others'
if(iarea.ge.800.and.iarea.le.999)area='Reserved'
c
write(ko,1) iref,proj,model
iemin=int(emin)
iemax=int(emax)
write(ko,5) izmin,izmax,iamin,iamax,iemin,iemax
c
do 100 nn=1,80
n=80-nn+1
if(author(n).ne.' ') go to 102
100 continue
102 nauth=min0(80,n)
write(ko,2)(author(n),n=1,nauth)
c
do 110 nn=1,80
n=80-nn+1
if(refer(n).ne.' ') go to 112
110 continue
112 nrefer=min0(80,n)
write(ko,3)(refer(n),n=1,nrefer)
c
do 120 nn=1,320
n=320-nn+1
if(summary(n).ne.' ') go to 122
120 continue
122 nsum=min0(320,n)
write(ko,4)(summary(n),n=1,nsum)
c
write(ko,6)(ldum,i=1,9)
return
end
****************** omtable code *******************
program omtable
c
c P.G.Young, Group T-2, Los Alamos National Laboratory
c Mail Stop B243, email address pgy@lanl.gov
c
c Code to summarize data in RIPL data file
c
parameter (ndim1=10, ndim2=11, ndim3=20, ndim4=30, ndim5=10,
1 ndim6=10,ndim7=120,ndim8=4000)
character*1 author,refer,summary
common/lib/iref,author(80),refer(80),summary(320),emin,emax,
1 izmin,izmax,iamin,iamax,imodel,jrange(5),epot(5,ndim1),
2 rco(5,ndim1,ndim2),aco(5,ndim1,ndim2),pot(5,ndim1,ndim3),
3 ncoll(ndim4),nvib(ndim4),nisotop,iz(ndim4),ia(ndim4),
4 lmax(ndim4),bandk(ndim4),def(ndim4,ndim5),idef(ndim4),
5 izproj,iaproj,exv(ndim7,ndim4),iparv(ndim7,ndim4),
6 nph(ndim7,ndim4),defv(ndim7,ndim4),thetm(ndim7,ndim4),
7 beta0(ndim4),gamma0(ndim4),xmubeta(ndim4),ex(ndim6,ndim4),
8 spin(ndim6,ndim4),ipar(ndim6,ndim4),spinv(ndim7,ndim4),
9 jcoul,ecoul(ndim1),rcoul(ndim1),rcoul0(ndim1),beta(ndim1)
c
c call qstart
c
open(unit=1,file='tape1',status='unknown')
open(unit=2,file='tape2',status='unknown')
open(unit=3,file='tape3',status='unknown')
c
c call filerep
c
ki=1
k2=2
k3=3
c
i1=0
i2=0
100 call omin(ki,ieof)
if(ieof.gt.0) go to 200
i1=i1+1
call catalog(i1,i2)
go to 100
200 n1=i1
n2=i2
write(*,*)'Number of library entries = ',n1
write(*,*)'Number of references = ',n2
call reptpr(n1,n2)
stop
end
subroutine omin(ki,ieof)
c
c Routine to print summary information from RIPL file
c
parameter (ndim1=10, ndim2=11, ndim3=20, ndim4=30, ndim5=10,
1 ndim6=10,ndim7=120,ndim8=4000)
character*1 author,refer,summary
common/lib/iref,author(80),refer(80),summary(320),emin,emax,
1 izmin,izmax,iamin,iamax,imodel,jrange(5),epot(5,ndim1),
2 rco(5,ndim1,ndim2),aco(5,ndim1,ndim2),pot(5,ndim1,ndim3),
3 ncoll(ndim4),nvib(ndim4),nisotop,iz(ndim4),ia(ndim4),
4 lmax(ndim4),bandk(ndim4),def(ndim4,ndim5),idef(ndim4),
5 izproj,iaproj,exv(ndim7,ndim4),iparv(ndim7,ndim4),
6 nph(ndim7,ndim4),defv(ndim7,ndim4),thetm(ndim7,ndim4),
7 beta0(ndim4),gamma0(ndim4),xmubeta(ndim4),ex(ndim6,ndim4),
8 spin(ndim6,ndim4),ipar(ndim6,ndim4),spinv(ndim7,ndim4),
9 jcoul,ecoul(ndim1),rcoul(ndim1),rcoul0(ndim1),beta(ndim1)
c
1 format(80a1)
c
do 80 i=1,80
author(i)=' '
80 refer(i)=' '
c
ieof=0
read(ki,*,end=999) iref
read(ki,1) (author(i),i=1,80)
read(ki,1) (refer(i),i=1,80)
read(ki,1) (summary(i),i=1,320)
read(ki,*) emin,emax
read(ki,*) izmin,izmax
read(ki,*) iamin,iamax
read(ki,*) imodel,izproj,iaproj
c
do 100 i=1,5
read(ki,*) jrange(i)
if(jrange(i).eq.0) go to 100
krange=iabs(jrange(i))
do 98 j=1,krange
read(ki,*) epot(i,j)
read(ki,*) (rco(i,j,n),n=1,ndim2)
read(ki,*) (aco(i,j,n),n=1,ndim2)
read(ki,*) (pot(i,j,n),n=1,ndim3)
98 continue
100 continue
read(ki,*) jcoul
if(jcoul.le.0) go to 110
do 108 j=1,jcoul
108 read(ki,*) ecoul(j),rcoul(j),rcoul0(j),beta(j)
110 if(imodel.ne.1) go to 130
read(ki,*) nisotop
do 120 n=1,nisotop
read(ki,*) iz(n),ia(n),ncoll(n),lmax(n),idef(n),bandk(n),
1 (def(n,k),k=2,idef(n),2)
do 124 k=1,ncoll(n)
read(ki,*) ex(k,n),spin(k,n),ipar(k,n)
124 continue
120 continue
go to 200
130 if(imodel.ne.2) go to 150
read(ki,*) nisotop
do 140 n=1,nisotop
read(ki,*) iz(n),ia(n),nvib(n)
do 138 k=1,nvib(n)
read(ki,*) exv(k,n),spinv(k,n),iparv(k,n),nph(k,n),defv(k,n),
1 thetm(k,n)
138 continue
140 continue
go to 200
150 if(imodel.ne.3)go to 200
read(ki,*) nisotop
do 160 n=1,nisotop
read(ki,*) iz(n),ia(n),beta0(n),gamma0(n),xmubeta(n)
160 continue
200 continue
read(ki,1,end=999) idum
return
999 ieof=1
return
end
subroutine catalog(i1,i2)
c
c routine to assemble table information for RIPL report.
c
parameter (ndim1=10, ndim2=11, ndim3=20, ndim4=30, ndim5=10,
1 ndim6=10,ndim7=120,ndim8=4000)
character*1 author,refer,summary
character*1 authx,referx
common/lib/iref,author(80),refer(80),summary(320),emin,emax,
1 izmin,izmax,iamin,iamax,imodel,jrange(5),epot(5,ndim1),
2 rco(5,ndim1,ndim2),aco(5,ndim1,ndim2),pot(5,ndim1,ndim3),
3 ncoll(ndim4),nvib(ndim4),nisotop,iz(ndim4),ia(ndim4),
4 lmax(ndim4),bandk(ndim4),def(ndim4,ndim5),idef(ndim4),
5 izproj,iaproj,exv(ndim7,ndim4),iparv(ndim7,ndim4),
6 nph(ndim7,ndim4),defv(ndim7,ndim4),thetm(ndim7,ndim4),
7 beta0(ndim4),gamma0(ndim4),xmubeta(ndim4),ex(ndim6,ndim4),
8 spin(ndim6,ndim4),ipar(ndim6,ndim4),spinv(ndim7,ndim4),
9 jcoul,ecoul(ndim1),rcoul(ndim1),rcoul0(ndim1),beta(ndim1)
common/rept/krefx(ndim8),idx(ndim8),izminx(ndim8),izmaxx(ndim8),
1 iaminx(ndim8),iamaxx(ndim8),eminx(ndim8),emaxx(ndim8),
2 imodelx(ndim8),irefx(ndim8),nauthx(ndim8),
3 lrefx(ndim8),authx(80,ndim8),referx(80,ndim8)
data jchkau,jchkref/40,40/
c
c Store reference information
c
irefx(i1)=iref
izminx(i1)=izmin
izmaxx(i1)=izmax
iaminx(i1)=iamin
iamaxx(i1)=iamax
eminx(i1) =emin
emaxx(i1) =emax
imodelx(i1) =imodel
c
c Get standard ID number
do 100 n=1,6
if(izproj.eq.0.and.iaproj.eq.1) idx(i1)=1
if(izproj.eq.1.and.iaproj.eq.1) idx(i1)=2
if(izproj.eq.1.and.iaproj.eq.2) idx(i1)=3
if(izproj.eq.1.and.iaproj.eq.3) idx(i1)=4
if(izproj.eq.2.and.iaproj.eq.3) idx(i1)=5
if(izproj.eq.2.and.iaproj.eq.4) idx(i1)=6
100 continue
c
c See how many characters are needed for the first author
do 110 n=3,80
nauthx(i1)=n-1
if(author(n).eq.' '.or.author(n).eq.',') go to 112
110 continue
nauthx(i1)=nauthx(i1)+1
112 continue
c
c Save entire author and reference arrays
do 120 n=1,80
authx(n,i1)=author(n)
referx(n,i1)=refer(n)
120 continue
c
c Check to see if this is a repeated reference
c
if(i1.eq.1) go to 170
do 150 i=1,i1-1
i11=i
do 140 j=1,jchkau
if(authx(j,i1).ne.authx(j,i)) go to 150
140 continue
do 146 j=1,jchkref
if(referx(j,i1).ne.referx(j,i)) go to 150
146 continue
go to 160
150 continue
go to 170
c
c Repeated Reference
c
160 continue
krefx(i1)=krefx(i11)
go to 200
c
c New Reference
c
170 i2=i2+1
lrefx(i2)=i1
krefx(i1)=i2
c
200 return
end
subroutine reptpr(n1,n2)
c
c routine to assemble table information for RIPL report.
c
parameter (ndim1=10, ndim2=11, ndim3=20, ndim4=30, ndim5=10,
1 ndim6=10,ndim7=120,ndim8=4000)
character*1 authx,referx,da,com,bl
character*3 proj
character*7 modbcd
common/rept/krefx(ndim8),idx(ndim8),izminx(ndim8),izmaxx(ndim8),
1 iaminx(ndim8),iamaxx(ndim8),eminx(ndim8),emaxx(ndim8),
2 imodelx(ndim8),irefx(ndim8),nauthx(ndim8),
3 lrefx(ndim8),authx(80,ndim8),referx(80,ndim8)
dimension proj(6),modbcd(4)
data nct/100000/
data (proj(id),id=1,6)/' n ',' p ',' d ',' t ','3He','4He'/
data com/','/,da/'-'/,bl/' '/
data (modbcd(i),i=1,4)/'spher. ','CC rot.','vibra. ','N/A def'/
c
1 format('Lib. Inc. Model Z-Range A-Range E-Range Ref.
1First ',/
2 ' No. Part. Type (MeV) No.
3Author ',/)
2 format(i4,2x,a3,3x,a7,i4,a1,i2,i6,a1,i3,f6.1,a1,f5.1,i6,2x,16a1)
3 format(' REFERENCES'/)
4 format(i3,'. ',66a1,/6x,66a1,/6x,66a1)
c
c Write table on tape2
c
i1=0
98 ict=0
write(2,1)
100 ict=ict+1
i1=i1+1
id=idx(i1)
im=imodelx(i1) + 1
write(2,2)irefx(i1),proj(id),modbcd(im),izminx(i1),da,izmaxx(i1),
1 iaminx(i1),da,iamaxx(i1),eminx(i1),da,emaxx(i1),
2 krefx(i1),(authx(j,i1),j=1,nauthx(i1))
if(i1.eq.n1) go to 120
if(ict.lt.nct) go to 100
go to 98
c
c Write references on tape3
c
120 i2=0
128 ict=0
write(3,3)
130 ict=ict+1
i2=i2+1
i1=lrefx(i2)
do 140 nn=1,80
n=80-nn+1
if(authx(n,i1).ne.' ')go to 142
140 continue
142 nauth=n
do 150 nn=1,80
n=80-nn+1
if(referx(n,i1).ne.' ')go to 152
150 continue
152 nref=n
write(3,4)i2,(authx(j,i1),j=1,nauth),com,bl,
1 (referx(j,i1),j=1,nref)
if(i2.eq.n2) go to 200
c if(ict.eq.nct) go to 128
go to 130
c
200 return
end