C
C MOLLER_LEVELS.FOR
C*********************************************************************
C v1.1, 20/08/1997, R.Capote
C*********************************************************************
C This code is a modified version of the original one,
C written by P.Moller, and provided with the SPL database(moller_levels.dat).
C AUTHOR of the MODIFIED VERSION: Dr.R.Capote,
C See capote_micro.for(sect.5.3 of the RIPL) for contact data.
C
C It allow to extract single particle scheme from MOELLER-NIX SPL
C database(moller_levels.dat) in the format required by the
C capote_micro.for(Sect.5.3) and obninsk_micro.for(Supplement)codes
C for microscopical level density calculations.
C
C INPUT FROM THE CONSOLE: Number of nucleus to retrieve SPL scheme
C Z and N for each requested nucleus
C OUTPUT: SINGLE PARTICLE SPECTRA according to the Z,A numbers
C (The extension of the output files is SPE)
C
C REMARK:
C This program assumes that file moller_levels.dat exists in the
C same directory, where you are running this program. !!!!
C
PROGRAM DENS_INP
CHARACTER CTMP*1,CTMP2*2,FOUT*7,CTMP3*3
C ,FNAME*3,FNAME1*2
DIMENSION IZT(20),INT(20),A(16),ILL(20),FOUT(20),DEF(6)
WRITE(6,*) 'HOW MANY NUCLEUS TO GET SP DATA? =>'
READ(5,*) NMAS
IF(NMAS.LT.1) STOP ' SHOULD BE AT LEAST ONE NUCLEUS'
IF(NMAS.GT.20) STOP ' YOU SHOULD ASK DATA FOR LESS THAN 20 NUCLEI'
WRITE(6,*) 'INPUT Z,N =>'
READ(5,*)(IZT(J),INT(J),J=1,NMAS)
WRITE(6,103)(IZT(J),INT(J),J=1,NMAS)
DO I=1,NMAS
IA=INT(I)+IZT(I)
IF(IZT(I).GT.9) THEN
WRITE(CTMP2,'(I2)') IZT(I)
FOUT(I)='Z'//CTMP2
IL=3
ELSE
WRITE(CTMP,'(I1)') IZT(I)
FOUT(I)='Z'//CTMP
IL=2
ENDIF
IF(IA.GT.99) THEN
WRITE(CTMP3,'(I3)') IA
FOUT(I)=FOUT(I)(1:IL)//'A'//CTMP3
IL=IL+4
ELSE
IF(IA.GT.9) THEN
WRITE(CTMP2,'(I2)') IA
FOUT(I)=FOUT(I)(1:IL)//'A'//CTMP2
IL=IL+3
ELSE
WRITE(CTMP,'(I1)') IA
FOUT(I)=FOUT(I)(1:IL)//'A'//CTMP
IL=IL+2
ENDIF
ENDIF
ILL(I)=IL
ENDDO
103 FORMAT(' REQUESTED Z N'/(10X,2I5))
IREQ=0
NINP=9
NOUT=10
C DO KR=1,14
C IF(KR.GT.9) THEN
C WRITE(CTMP2,'(I2)') KR
C FNAME='A'//CTMP2
C open(NINP,file=fname)
C ELSE
C WRITE(CTMP,'(I1)') KR
C FNAME1='A'//CTMP
C open(NINP,file=fname1)
C ENDIF
OPEN(NINP,file='moller_levels.dat')
C******* ON TAPE NOUT STORES LEVELS SELECTED *************
10 KMEMO=0
READ(NINP,100,END=71)IZ,IN,IA
DO 20 J=1,NMAS
IF(IZ.EQ.IZT(J).AND.INT(J).EQ.IN)KMEMO=1
20 CONTINUE
IF(KMEMO.NE.0)IREQ=IREQ+1
IF(KMEMO.NE.0)OPEN(NOUT,file=FOUT(IREQ)(1:ILL(IREQ))//'.SPE')
C IF(KMEMO.NE.0)WRITE(NOUT,100)IZ,IN,IA,A(1),A(2),A(3)
C IF(KMEMO.NE.0)WRITE(6,104)IZ,IN
C READ(NINP,101)A
IF(KMEMO.NE.0)THEN
READ(NINP,*) DEF(1),DEF(2),DEF(3)
READ(NINP,*) DEF(4),DEF(5),DEF(6)
ELSE
READ(NINP,101) A
READ(NINP,101) A
ENDIF
IF(KMEMO.NE.0)WRITE(NOUT,1100)IZ,IN,IA,DEF
IF(KMEMO.NE.0)WRITE(6,1104)IZ,IN,DEF
IF(KMEMO.EQ.0) GO TO 31
AIA=1.0/FLOAT(IA)**0.33333333
FP=31.08*AIA
FN=35.37*AIA
C
C NEUTRON LEVELS
C
31 READ(NINP,100) NUM
IF(KMEMO.NE.0)WRITE(NOUT,100)NUM
IF(KMEMO.NE.0)WRITE(6,106)NUM
DO 9 I=1,NUM
READ(NINP,121) E,IJ
IF(KMEMO.EQ.0) GO TO 9
C WRITE(6,121) E,IJ
C E=E/FN
C IF(I.EQ.1) E0=1.5-E
C E=E+E0
S=IJ/2.0
PI=SIGN(1.0,S)
S=ABS(S)
WRITE(NOUT,122) E,S,PI
9 CONTINUE
C
C PROTON LEVELS
C
READ(NINP,100) NUM
IF(KMEMO.NE.0)WRITE(NOUT,100)NUM
IF(KMEMO.NE.0)WRITE(6,106)NUM
DO 19I=1,NUM
READ(NINP,121) E,IJ
IF(KMEMO.EQ.0) GO TO 19
C WRITE(6,121) E,IJ
C E=E/FP
C IF(I.EQ.1) E0=1.5-E
C E=E+E0
S=IJ/2.0
PI=SIGN(1.0,S)
S=ABS(S)
WRITE(NOUT,122) E,S,PI
19 CONTINUE
IF(KMEMO.NE.0) CLOSE(NOUT,STATUS='KEEP')
IF(IREQ.GE.NMAS)GOTO 77
GOTO 10
C 71 IF(KR.EQ.14) WRITE(6,111)
71 WRITE(6,111)
CLOSE(NINP)
C ENDDO
C 70 CONTINUE
77 CLOSE(NINP)
STOP
100 FORMAT(3I10)
1100 FORMAT(3(I3,1X),6(E10.4,1X))
101 FORMAT(16A4)
121 FORMAT(F10.4,I10)
122 FORMAT(E16.6,F10.1,F5.0)
1104 FORMAT(' SELECTED Z N'/(9X,2I5/10X,'DEF=',6(E10.4,1X))/)
104 FORMAT(' SELECTED Z N'/(9X,2I5))
106 FORMAT(' NUMBER OF LEVELS ',I4)
111 FORMAT(5X' E N D O F T A P E S ! ! ! ! ! ! ',/,
X5X,' SOME REQUESTED NUCLEI NOT FOUND')
END