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