difh23b/lec2BRf
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
REAL*4 TRP,SPO
CHARACTER*4 ETAT
CHARACTER*50 fichier
character*80 t80
dimension trp(100,2000,2),eve(100),evfp(2000),evfr(2000)
1,spo(100,5),t80(80)
c fichier='print'
fichier='zip2.herab:print'
open(7,file=fichier,status='NEW')
c fichier='RPcontj01'
fichier='zip2.herab:difh21:RPcontj07'
write(7,*) fichier
open(31,file=fichier,status='old')
ilec=31
63 FORMAT(80A1)
do 1 iet=1,4
call lcontrp(ilec,ibe,iefin,iffip,iffir,evfp,evfr,etat
1,eve,spo,trp,100,2000)
write(7,*)etat
write(7,*) 'ibe,iefin,iffip,iffir,'
write(7,*) ibe,iefin,iffip,iffir
write(7,*) 'upper state energy level from H1S+H2S'
write(9,*) 'ibe,iefin,iffip,iffir,'
write(9,*) ibe,iefin,iffip,iffir
write(9,*) 'upper state energy level from H1S+H2S'
write(7,370) (eve(ie),ie=1,iefin)
write(9,370) (eve(ie),ie=1,iefin)
370 FORMAT(1X,4(1X,F15.5))
DO 5 I=1,4
write(7,*) 'proportion of state ',I
write(7,37)(SPO(IE,I),IE=1,IEFIN)
write(9,*) 'proportion of state ',I
write(9,37)(SPO(IE,I),IE=1,IEFIN)
5 CONTINUE
37 FORMAT(1X,5E13.6)
ie=1
nvu=ie-1
nju=ibe-1
write(7,*) 'dissociative emission from ', etat
1 ,' v=',nvu,' J=',nju
write(7,*) 'if,K.E.,AP,AR'
do 2 if=1,50
write(7,371) if,evfp(if),trp(ie,if,1),trp(ie,if,2)
371 format(1x,I5,1x,F15.5,2(1x,e13.6))
2 continue
if50=iffip-50
do 3 if=if50,iffip
write(7,371) if,evfp(if),trp(ie,if,1),trp(ie,if,2)
3 continue
1 continue
stop
end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
SUBROUTINE lcontrp(ILEC,IBE,IEFIN,IFFIP,IFFIR,evfp,evfr,ETAT
1 ,EVE,SPO,TRP,IDIVE,IDIVF)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
REAL*4 TRP,SPO
CHARACTER*4 ETAT
CHARACTER*1 T80
DIMENSION EVE(IDIVE),TRP(IDIVE,IDIVF,2),SPO(IDIVE,5),IM1(100)
1 ,T80(80)
1 ,evfp(idivf),evfr(idivf)
DO 120 IDE=1,IDIVE
EVE(IDE)=0.D0
DO 121 IS=1,5
121 SPO(IDE,IS)=0.
DO 120 IDF=1,IDIVF
TRP(IDE,IDF,1)=0.
TRP(IDE,IDF,2)=0.
120 CONTINUE
READ(ILEC,40)IBE,IEFIN,IFFIP,IFFIR,ETAT
IEMIN=1
IFMIN=1
PRINT 40,IBE,IEFIN,IFFIP,IFFIR,ETAT
40 FORMAT(1X,4I10,A4)
38 FORMAT(1X,10I7)
C PRINT 199,ETAT
199 FORMAT(1X,'E STATE HAS LABEL ',1A4)
c write(6, *) 'ETAT LWBCP5',ETAT,ibe
READ(ILEC,63)(T80(I),I=1,80)
63 FORMAT(130A1)
IEMIN=1
IFMIN=1
DO 3 I=1,100
IM1(I)=I-1
3 CONTINUE
READ(ILEC,63)(T80(J),J=1,80)
C PRINT 64,(T80(J),J=1,80)
READ(ILEC, 370)(EVE(IE),IE=IEMIN,IEFIN)
C PRINT 370,(EVE(IE),IE=IEMIN,IEFIN)
DO 5 I=1,4
READ(ILEC,63)(T80(J),J=1,80)
C PRINT 64,(T80(J),J=1,80)
READ(ILEC,37)(SPO(IE,I),IE=1,IEFIN)
C PRINT 37,(SPO(IE,I),IE=1,IEFIN)
5 CONTINUE
37 FORMAT(1X,5E13.6)
370 FORMAT(1X,4(1X,F15.5))
DO 1 NDJ=2,1,-1
IF(NDJ.EQ.2) IBF=IBE-1
IF(NDJ.EQ.2) IFFIN=IFFIR
IF(NDJ.EQ.1) IBF=IBE+1
IF(NDJ.EQ.1) IFFIN=IFFIP
C DO 250 I=1,2
READ(ILEC,63)(T80(J),J=1,80)
C PRINT 64,(T80(J),J=1,80)
C250 CONTINUE
64 FORMAT(1X,130A1)
4 FORMAT(//)
C READ(ILEC,63)(T80(I),I=1,80)
C PRINT 64,(T80(I),I=1,80)
DO 22 IET=1,20
IET1=IEMIN+4*(IET-1)
IF(IET1.GT.IEFIN) GO TO 223
IET2=MIN0(IEMIN+4*IET-1,IEFIN)
READ(ILEC,63)(T80(I),I=1,80)
C PRINT 64,(T80(I),I=1,80)
2 FORMAT(/)
DO 21 IF=IFMIN,IFFIN
if(ndj.eq.2)read(ilec,304)EVFr(IF),(TRP(IE,IF,NDJ),IE=IET1,IET2)
if(ndj.eq.1)read(ilec,304)EVFp(IF),(TRP(IE,IF,NDJ),IE=IET1,IET2)
c READ(ILEC,306)(TRP(IE,IF,NDJ),IE=IET1,IET2)
C PRINT304,IM1(IF),(TRP(IE,IF,NDJ),IE=IET1,IET2)
304 FORMAT (1X,F11.2,1X ,4E13.6)
306 FORMAT (1X,13X,4E13.6)
260 FORMAT(1X,A4)
21 CONTINUE
22 CONTINUE
223 CONTINUE
DO 251 I=1,3
READ(ILEC,63)(T80(J),J=1,80)
C PRINT 64,(T80(J),J=1,80)
251 CONTINUE
C PRINT 4
1 CONTINUE
RETURN
END
ccccccccccccccccccccccccccccccccccccccccccccccccmmmmmmmmmm
